home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / Nuc source / Nuc2.asm < prev    next >
Assembly Source File  |  1993-02-25  |  66KB  |  3,630 lines
  1. ; Now we set up for the first word in the dictionary:
  2.  
  3. d
  4.  
  5. q0    set    0
  6. q1    set    0
  7. q2    set    0
  8. q3    set    0
  9. q4    set    0
  10. q5    set    0
  11. q6    set    0
  12. q7    set    0
  13.  
  14. ; Note: the first link field must not be located at d.  So we put a few other things
  15. ; before the first header.
  16.  
  17. ;        ======================================
  18.  
  19. ;           OBJECTS, CONSTANTS, VALUES etc.
  20.  
  21. ;        ======================================
  22.  
  23. FreeHeap    long    ; Used during setup
  24. ExpDicq    byte    ; Set while we're expecting a dic image
  25. DicRead    byte    ; Set when we've just read one
  26. RAinMod    byte    ; Set if a relocatable address is in a module
  27. ErrInfoValid
  28.     byte    ; Set if there's valid saved error info
  29.     align
  30.  
  31.  
  32. ; Many system objects are up in the overlap area.  We just define
  33. ; their _t codes here.
  34.  
  35. fWind_t    set    doObj
  36. fEvent_t    set    doObj
  37. fpRect_t    set    doObj
  38. fdRect_t    set    doObj
  39.  
  40. ; fFcb object is now allocated in the heap - fFcb itself is an object pointer.
  41.  
  42.     head    4,FFCB,fFcb,doObjPtr        ; FFCB
  43.  
  44.     head    5,FWIND,fWind,doObj        ; FWIND
  45.     byte    $9C
  46.     dc.w    $F,2,$116,$1EE        ; contRect
  47.     byte    $2E
  48.  
  49.     valu    3,TIB,tib        ; TIB
  50.     valu    3,PAD,pad        ; PAD
  51.     valu    8,^ERRDUMP,PtrErrDump        ; ^ERRDUMP
  52.     valu    6,THERGN,TheRgn        ; TheRgn
  53.  
  54.     varbl    11,EXTRALOCALS,ExtraLocals        ; ExtraLocals
  55.     long    20
  56. ExtraLocalsEnd
  57.     const    6,TIBLEN,.tibln,tibLen        ; TIBLEN
  58.     varbl    4,#TIB,ntib        ; #TIB
  59.     long
  60.     varbl    3,>IN,toin        ; >IN
  61.     long
  62.     valu    9,SRC-START,srcstart        ; SRC-START
  63.     valu    7,SRC-LEN,srclen        ; SRC-LEN
  64.     valu    9,SOURCE-ID,sourceID        ; SOURCE-ID
  65.  
  66.     valu    7,SAVEDRP,savedRP        ; SavedRP
  67.     valu    3,OUT,out        ; OUT
  68.     valu    5,STATE,state        ; STATE
  69.     valu    6,CSTATE,cstate        ; CSTATE
  70.     valu    4,BASE,nbase,10        ; BASE
  71.     valu    3,DPL,dpl        ; DPL
  72.     valu    3,HLD,hld        ; HLD
  73.     nvalu    throwHandler        ; ThrowHandler
  74.     nvalu    DotStkLim,$7FFFFFFF        ; DotStkLim
  75.     valu    10,SLEEPTICKS,sleepTicks,-1    ; SLEEPTICKS
  76.     valu    5,MMRGN,MMRgn,0        ; MMRGN
  77.     valu    7,EXBOFFS,exBoffs        ; EXBOFFS
  78.     valu    7,MROPEN?,.MRopen,0        ; MROPEN?
  79.     valu    7,INSTLD?,instldq,0        ; INSTLD?
  80.     valu    8,INITZED?,itzed,0        ; INITZED?
  81.     valu    8,QUITAPP?,QuitAppq,0        ; QUITAPP?
  82.     valu    6,FWIND?,fWindq,-1        ; FWIND?
  83.     valu    9,WNEAVAIL?,WNEavail,0        ; WNEavail?
  84.     valu    9,HWPAVAIL?,HWPavail        ; HWPavail?
  85.     valu    13,GESTALTAVAIL?,GestaltAvail    ; GestaltAvail?
  86.     valu    12,APPLEEVENTS?,AppleEventsQ    ; AppleEvents?
  87.     valu    6,(ERR#),pErrNum,0        ; (Err#)
  88.     valu    11,#DOCSTOOPEN,NumDocsToOpen    ; #docsToOpen
  89.     valu    4,FPU?,FPUq        ; FPU?
  90.     valu    6,SAMASK,SAmask        ; SAmask
  91.     valu    9,PROCESSOR,processor        ; PROCESSOR
  92.     valu    6,MAXDIC,MaxDic,300000        ; MAXDIC
  93.     valu    7,MINHEAP,MinHeap,20000        ; MINHEAP
  94.     valu    7,DICSIZE,dicsize        ; DICSIZE
  95.     valu    8,STKSPACE,stkSpace,50000        ; STKSPACE
  96.     valu    9,RSTKSPACE,RstkSpace,6000        ; RSTKSPACE
  97.     valu    3,SP0,sp0        ; SP0
  98.     valu    3,RP0,rp0        ; RP0
  99.     valu    4,LOC#,locno        ; LOC#
  100.     valu    2,#P,numP        ; #P
  101.     valu    3,#PL,numPL        ; #PL
  102.     valu    2,#F,numF        ; #F
  103.     valu    6,FLTFLG,FltFlg        ; fltFlg
  104.     valu    6,LOCAL?,localq,0        ; local?
  105.     valu    7,METHOD?,methodq,0        ; method?
  106.     valu    8,SELFREF?,selfRefq        ; selfref?
  107.     valu    8,OBJCLASS,objClass        ; objClass
  108.     valu    4,#1ST,num1st        ; #1st
  109.     valu    5,#LAST,numLast        ; #Last
  110.     valu    7,HELDMOD,heldMod        ; HeldMod
  111.     long    ;   (extra location to save old A5 while a module is held)
  112.     valu    9,METHINDEX,MethIndex        ; MethIndex
  113.     valu    6,MBCOMP,MBcomp        ; MBcomp
  114.     valu    7,SACOMP?,SAcomp        ; SAcomp?
  115.     valu    9,RELOCCHK?,RelocChkq,-1        ; RelocChk?
  116.     valu    10,INHIBITMB?,inhibitMBq        ; InhibitMB?
  117.     valu    7,COMPMOD,compMod        ; CompMod
  118.  
  119. ; The following 8 values will be set by the floating point code, to the
  120. ; addresses of the corresponding words, FPDisp etc.  These addresses are
  121. ; used by Handlers to compile calls to the corresponding words.
  122.  
  123.     valu    7,^FPDISP,ptrFPdisp,-1        ; ptrFPdisp
  124.     valu    8,^FPDISP2,ptrFPdisp2,-1        ; ptrFPdisp2
  125.     valu    6,^FPNEW,ptrFPnew,-1        ; ptrFPnew
  126.     valu    7,^FPULIT,ptrFPULit,-1        ; ptrFPULit
  127.     valu    7,^LFLOAT,ptrLfloat,-1        ; ptrLfloat
  128.     valu    9,^TOLFLOAT,ptrToLfloat,-1        ; ptrToLfloat
  129.     valu    7,^TOFVAL,ptrToFval,-1        ; ptrToFval
  130.     valu    7,^LFDISP,ptrLFdisp,-1        ; ptrLFdisp
  131.  
  132.     const    2,BL,bl,32        ; BL
  133.     const    4,TRUE,true,-1        ; TRUE
  134.     const    5,FALSE,false,0        ; FALSE
  135.     const    8,#THREADS,nthreads,8        ; #THREADS
  136.     const    4,BIG#,bigno,$7FFFFFFF        ; BIG#
  137.  
  138. ; Some handler code values that we need to be able to access from
  139. ; above the nucleus:
  140.  
  141.     const    9,CLASSCODE,.classCode,class_h    ; CLASSCODE
  142.     const    7,OBJCODE,.objCode,obj_h        ; OBJCODE
  143.     const    8,FVALCODE,.FvalCode,Fval_h    ; FVALCODE
  144.  
  145.     const    4,NILH,nilH,$FFA00101        ; NILH
  146.     const    4,NILP,nilP,$FFA00103        ; NILP
  147.  
  148.     nvalu    diskErr,0        ; DISK-ERROR
  149.     valu    4,CURS,curs,-1        ; CURS
  150.     valu    6,UCFLAG,ucflag,-1        ; UCFLAG
  151.     valu    4,OPT?,optq,-1        ; OPT?
  152.     const    5,INLMK,inlMk,$4AFC        ; INLMK
  153.  
  154. currBase
  155.     byte
  156. fmkCnt    byte
  157. callOut    byte
  158. CCmpFlg    byte
  159. colAflg    byte
  160.     align
  161.  
  162. ODaddr    long
  163.  
  164. TempPtr    ptr
  165. Temp    byte    20    ; This gets used for a few things.
  166.  
  167.  
  168. ;        =============================
  169.  
  170. ;               SYSTEM VECTORS
  171.  
  172. ;        =============================
  173.  
  174. ; First, some non-in-line versions of any words that are needed
  175. ; for vectors.  A word assigned to a vector must be able to be JSR'd to.
  176.  
  177.     head    6,VFALSE,vfalse        ; VFALSE
  178.     parms    false
  179.     rts
  180.  
  181. ; That was the only one!!
  182.  
  183.     svec    7,EMITVEC,emitvec,pemit        ; EMITVEC
  184.     svec    8,PEMITVEC,pemitvec,drop        ; PEMITVEC
  185.     svec    5,CRVEC,crvec,pcr        ; CRVEC
  186.     svec    6,PCRVEC,pcrvec        ; PCRVEC
  187.     svec    7,TYPEVEC,typevec,ptype        ; TYPEVEC
  188.     svec    8,PTYPEVEC,ptypevec,twodrop    ; PTYPEVEC
  189.     svec    7,ECHOVEC,echovec,pemit        ; ECHOVEC
  190.     svec    6,HEADER,header,pheader        ; HEADER
  191.     svec    6,LOGVEC,logvec        ; LOGVEC
  192.  
  193.  
  194. ;    ==================================
  195.  
  196. semis_m    macrox
  197.     RTS
  198.     endm
  199.     nohead    semis,inline        ; ;S
  200.  
  201. pexit_m    macrox
  202.     RTS
  203.     endm
  204.     head    6,(EXIT),pexit,inline        ; (EXIT)
  205.  
  206.  
  207. ; DO loops
  208.  
  209. DO_M    macrox    &1
  210.     LEA    &1,A1
  211.     JSR    DoSetup-base(A3)
  212.     endm
  213.  
  214. QDO_M    macrox    &1
  215.     LEA    &1,A1
  216.     JSR    QDoSetup-base(A3)
  217.     endm
  218.  
  219.  
  220. DoSetup
  221.     MOVE.L    (A7),A0    ; Save rtn addr
  222.     MOVE.L    D3,(A7)    ; Save old i
  223.     MOVE.L    (A6)+,D3    ; New i
  224.     MOVE.L    A1,-(A7)    ; LEAVE address
  225.     MOVE.L  (A6)+,-(A7)    ; Limit
  226.     JMP    (A0)    ; Return
  227.  
  228. QDoSetup
  229.     MOVE.L    A6,A0    ; Copy of data stk ptr to A0
  230.     CMPM.L    (A0)+,(A0)+    ; Compare index, limit
  231.     BGT.S    DoSetup    ; Limit greater - continue with loop
  232.     ADDQ    #8,A6    ; LE - skip loop - drop index and limit
  233.     ADDQ    #4,A7    ;  and return address
  234.     JMP    (A1)    ; And jump instead to after (+)LOOP code
  235.  
  236.  
  237. LOOP_M    macrox    &1
  238.     ADDQ.L    #1,D3
  239.     CMP.L    (A7),D3
  240.     BLT    &1
  241.     ADDQ.L    #8,A7
  242.     MOVE.L    (A7)+,D3
  243.     endm
  244.  
  245. PlLoop_M    macrox    &1
  246.     POP.L    D0
  247.     BPL.S    .up
  248.     ADD.L    D0,D3
  249.     MOVE.L    (A7),D0
  250.     SUBQ.L    #1,D0
  251.     CMP.L    D3,D0
  252.     BRA.S    .tst
  253.  
  254. .up    ADD.L    D0,D3
  255.     CMP.L    (A7),D3
  256. .tst    BLT    &1
  257.     ADDQ.L    #8,A7
  258.     MOVE.L    (A7)+,D3
  259.     endm
  260.  
  261. PlLpD_M    macrox    &1
  262.     BPL.S    .up
  263.     ADD.L    D0,D3
  264.     MOVE.L    (A7),D0
  265.     SUBQ.L    #1,D0
  266.     CMP.L    D3,D0
  267.     BRA.S    .tst
  268.  
  269. .up    ADD.L    D0,D3
  270.     CMP.L    (A7),D3
  271. .tst    BLT    &1
  272.     ADDQ.L    #8,A7
  273.     MOVE.L    (A7)+,D3
  274.     endm
  275.  
  276. plLpUp_m    macrox    &1
  277.     CMP.L    (A7),D3
  278.     BLT    &1
  279.     ADDQ.L    #8,A7
  280.     MOVE.L    (A7)+,D3
  281.     endm
  282.  
  283. PlLpDn_m    macrox    &1
  284.     CMP.L    (A7),D3
  285.     BGE    &1
  286.     ADDQ.L    #8,A7
  287.     MOVE.L    (A7)+,D3
  288.     endm
  289.  
  290. windupDo
  291.     ADDQ.L    #8,A7
  292.     MOVE.L    (A7)+,D3
  293.  
  294.  
  295. doLeave    ADDQ.L    #4,A7    ; Pop limit
  296.     MOVE.L    (A7)+,A0    ; Loop end addr to A0 so we can go there
  297.     MOVE.L    (A7)+,D3    ; Restore old i
  298.     JMP    (A0)    ; Goto loop end
  299.  
  300.  
  301. pdo_m    macrox
  302.     do_m    dummylab
  303.     endm
  304.  
  305. pqdo_m    macrox
  306.     qdo_m    dummylab
  307.     endm
  308.  
  309. ploop_m    macrox
  310.     loop_m    dummylab
  311.     endm
  312.  
  313. pplloop_m    macrox
  314.     plLoop_m    dummylab
  315.     endm
  316.  
  317. ppLpD_m    macrox
  318.     PlLpD_m    dummylab
  319.     endm
  320.  
  321. ppLpUp_m    macrox
  322.     plLpup_m    dummylab
  323.     endm
  324.  
  325. ppLpDn_m    macrox
  326.     plLpDn_m    dummylab
  327.     endm
  328.  
  329.     loc
  330.     nohead    pdo,inline        ; (do)
  331.     loc
  332.     nohead    pqdo,inline        ; (?do)
  333.     loc
  334.     nohead    ploop,inline        ; (loop)
  335.     loc
  336.     nohead    pplloop,inline        ; (+loop)
  337.     loc
  338.     nohead    ppLpD,inline
  339.     loc
  340.     nohead    ppLpUp,inline
  341.     loc
  342.     nohead    ppLpDn,inline
  343.     loc
  344.     word
  345.  
  346. ; These are called e.g. by
  347. ;    compyl    pdo
  348. ; followed by an adjustment so that >MARK etc. can be used to
  349. ; set up the branches.
  350.  
  351. dummyLab
  352.     _Debugger
  353.  
  354.  
  355. ; DoNoOpt is called by the NoOpt macro.
  356.  
  357. DoNoOpt    PUSH.L    A0    ; Save A0 - anything might be going on!
  358.     MOVE.L    ODaddr,A0
  359.     CLR.W    (A0)
  360.     POP.L    A0    ; Restore A0
  361.     RTS
  362.  
  363. ; DoSavA5 is called by the SavA5 macro.
  364.  
  365.     head    7,DOSAVA5,DoSavA5
  366.  
  367.     move.l    (a7),a1    ; Rtn addr to A1 (FCB words use A0!)
  368.     move.l    a5,(a7)    ; Save A5 on return stack
  369.     move.l    a7,savedRP-base(a3)    ; Save RP for :PROC
  370.     move.l    CurrentA5,a5    ; Set A5 and SP to what the system expects
  371.     exg    a6,a7
  372.     jmp    (a1)
  373.  
  374.  
  375. ;    ============  A few miscellaneous items ============
  376.  
  377. myRegs    long    4    ; Saves Mops' A3-A5 and A7, for :PROC.
  378.  
  379. ChkLim    word    ; Used in limit checking
  380.  
  381. ; Some quantities we need in handling AppleEvents.
  382.  
  383. ;fAE    long
  384. AEReply    long
  385. AERefCon    long
  386.  
  387.  
  388. ;    ======== Dictionary header address conversion ========
  389.  
  390.  
  391.     head    8,TRAVERSE,traverse        ; TRAVERSE
  392.     bra    doTraverse
  393.  
  394. NtoLink_m    macrox
  395.     SUBQ.L    #4,(A6)
  396.     endm
  397.     head    6,N>LINK,NtoLink,inline        ; N>LINK
  398.  
  399. LtoName_m    macrox
  400.     ADDQ.L    #4,(A6)
  401.     endm
  402.     head    6,L>NAME,LtoName,inline        ; L>NAME
  403.  
  404.     head    5,NAME>,namefrom        ; NAME>
  405.     n    1
  406.     parms    traverse
  407.     ADDQ.L    #3,(A6)
  408.     parms    semis
  409.  
  410.     head    5,LINK>,linkfrom        ; LINK>
  411.     parms    LtoName,namefrom,semis
  412.  
  413.     head    5,>BODY,tobody        ; >BODY
  414.     MOVE.L    (A6),A0
  415.     MOVE.W    -2(A0),D0    ; Handler addr to D7 (word)
  416.     MOVEQ    #0,D1
  417.     MOVE.W    -2(A3,D0.W),D1    ; >body offset to D0
  418.     ADD.L    D1,(A6)
  419.     next
  420.     
  421.     head    5,>NAME,toName        ; >NAME
  422.     SUBQ.L    #3,(A6)
  423.     n    -1
  424.     parms    traverse,semis
  425.  
  426.     head    5,>LINK,toLink        ; >LINK
  427.     parms    toName,NtoLink,semis
  428.  
  429.     head    4,>HDLR,toHdlr        ; >HDLR
  430.     subq.l    #2,(A6)
  431.     rts
  432.  
  433.  
  434. ;        ========================
  435.  
  436. ;            STACK MANIPULATION
  437.  
  438. ;        ========================
  439.  
  440. drop_m    macrox
  441.     ADDQ.L    #4,A6
  442.     endm
  443.     head    4,DROP,drop,inline        ; DROP
  444.  
  445. twoDrop_m    macrox
  446.     ADDQ.L    #8,A6
  447.     endm
  448.     head    5,2DROP,twoDrop,inline        ; 2DROP
  449.  
  450. nip_m    macrox
  451.     POP.L    (A6)
  452.     endm
  453.     head    3,NIP,nip,inline,tsCCOK        ; NIP
  454.  
  455. swap_m    macrox
  456.     pop.l    d0
  457.     move.l    (a6),d1
  458.     move.l    d0,(a6)
  459.     push.l    d1
  460.     endm
  461.     head    4,SWAP,swap,xinfo,,swap_h        ; SWAP
  462.     dc.w    otSWAP*256
  463.     use    swap
  464.  
  465. dup_m    macrox
  466.     PUSH.L    (A6)
  467.     endm
  468.     head    3,DUP,dup,inline,tsdup        ; DUP
  469.  
  470.     head    4,2DUP,twoDup,docode,tsCCOK    ; 2DUP
  471.     PUSH.L    4(A6)
  472.     PUSH.L    4(A6)
  473.     RTS
  474.  
  475. qdup_m    macrox
  476.     TST.L    (A6)
  477.     BEQ.S    .end
  478.     PUSH.L    (A6)
  479. .end
  480.     endm
  481.     head    4,?DUP,qdup,inline,tsCCok        ; ?DUP
  482.  
  483. zdup_m    macrox
  484.     TST.L    (A6)
  485.     BNE.S    .end
  486.     PUSH.L    (A6)
  487. .end
  488.     endm
  489.     head    4,0DUP,zdup,inline,tsCCok        ; 0DUP
  490.  
  491. over_m    macrox
  492.     PUSH.L    4(A6)
  493.     endm
  494.     head    4,OVER,over,inline,otOver*256    ; OVER
  495.  
  496.     head    4,TUCK,tuck,docode,tsCCOK    ; TUCK
  497.     pop.l    d0
  498.     move.l    (a6),d1
  499.     move.l    d0,(a6)
  500.     push.l    d1
  501.     push.l    d0
  502.     rts
  503.  
  504.     head    3,ROT,rot,docode,tsCCOK        ; ROT
  505.     movem.l    (a6)+,d1/d2/a0
  506.     move.l    a0,d0
  507.     movem.l    d0-d2,-(a6)
  508.     rts
  509.  
  510.     head    4,DOWN,down        ; DOWN
  511.     movem.l    (a6)+,d0-d2
  512.     move.l    d0,a0
  513.     movem.l    d1/d2/a0,-(a6)
  514.     rts
  515.  
  516.     head    4,PICK,pick,docode,tsCCOK        ; PICK
  517.     move.l    (a6),d0
  518.     asl.l    #2,d0
  519.     move.l    4(a6,d0.w),(a6)
  520.     rts
  521.  
  522.  
  523. ;        =============================
  524.  
  525. ;             SIMPLE ARITHMETIC
  526.  
  527. ;        =============================
  528.  
  529. plus_m    macrox
  530.     POP.L    D0
  531.     ADD.L    D0,(A6)
  532.     endm
  533.  
  534.     head    1,+,plus,xinfo,,pm_h        ; +
  535.     dc.w    otADD
  536.     use    plus
  537.  
  538. minus_m    macrox
  539.     POP.L    D0
  540.     SUB.L    D0,(A6)
  541.     endm
  542.  
  543.     head    1,-,minus,xinfo,,pm_h        ; -
  544.     dc.w    otSUB
  545.     use    minus
  546.  
  547.     head    3,MAX,max        ; MAX
  548.     POP.L    D0
  549.     CMP.L    (A6),D0
  550.     BLT.S    .end
  551.     MOVE.L    D0,(A6)
  552. .end    NEXT
  553.  
  554.     head    3,MIN,min        ; MIN
  555.     POP.L    D0
  556.     CMP.L    (A6),D0
  557.     BGT.S    .end
  558.     MOVE.L    D0,(A6)
  559. .end    NEXT
  560.  
  561. negate_m    macrox
  562.     NEG.L    (A6)
  563.     endm
  564.  
  565.     head    6,NEGATE,negate,xinfo,,pm_h    ; NEGATE
  566.     dc.w    otNEG
  567.     use    negate
  568.  
  569.     head    2,+-,plmin        ; +-
  570.     TST.L    (A6)+
  571.     BPL.S    .end
  572. doneg    NEG.L    (A6)
  573. .end    RTS
  574.  
  575.     head    3,ABS,abs        ; ABS
  576.     TST.L    (A6)
  577.     BMI.S    doneg
  578.     RTS
  579.  
  580.     head    7,ALIGNED,aligned        ; ALIGNED
  581. ; ( n -- n' )
  582.     moveq    #1,d0
  583.     and.l    (a6),d0
  584.     add.l    d0,(a6)
  585.     rts
  586.  
  587.     head    6,EXTEND,extend        ; EXTEND
  588.     move.l    (a6),d0
  589.     ext.l    d0
  590.     move    d0,(a6)
  591.     rts
  592.  
  593.     head    3,S>D,StoD        ; S>D
  594.     tst.l    (a6)
  595.     smi    d0
  596.     ext.w    d0
  597.     ext.l    d0
  598.     push.l    d0
  599.     rts
  600.  
  601.  
  602. ; Increments, decrements etc.  These are defined here as macros, only for the
  603. ; nucleus itself.  In the file Base they are defined properly as immediate words
  604. ; so our optimization can deal with them.
  605.  
  606. onep_m    macrox
  607.     ADDQ.L    #1,(A6)
  608.     endm
  609.     nohead    onep,inline        ; 1+
  610.  
  611. twop_m    macrox
  612.     ADDQ.L    #2,(A6)
  613.     endm
  614.     nohead    twop,inline        ; 2+
  615.  
  616. threep_m    macrox
  617.     ADDQ.L    #3,(A6)
  618.     endm
  619.     nohead    threep,inline        ; 3+
  620.  
  621. fourp_m    macrox
  622.     ADDQ.L    #4,(A6)
  623.     endm
  624.     nohead    fourp,inline        ; 4+
  625.  
  626. onem_m    macrox
  627.     SUBQ.L    #1,(A6)
  628.     endm
  629.     nohead    onem,inline        ; 1-
  630.  
  631. twom_m    macrox
  632.     SUBQ.L    #2,(A6)
  633.     endm
  634.     nohead    twom,inline        ; 2-
  635.  
  636. threem_m    macrox
  637.     SUBQ.L    #3,(A6)
  638.     endm
  639.     nohead    threem,inline        ; 3-
  640.  
  641. fourm_m    macrox
  642.     SUBQ.L    #4,(A6)
  643.     endm
  644.     nohead    fourm,inline        ; 4-
  645.  
  646.  
  647. twostar_m    macrox
  648.     MOVE.L    (A6),D0
  649.     ADD.L    D0,(A6)
  650.     endm
  651.     head    2,2*,twostar,inline        ; 2*
  652.  
  653. twosl_m    macrox
  654.     MOVE.L    (A6),D0
  655.     ASR.L    #1,D0
  656.     MOVE.L    D0,(A6)
  657.     endm
  658.     head    2,2//,twosl,inline        ; 2/
  659.  
  660.  
  661. ;        =======================
  662.  
  663. ;          LOGICAL OPERATIONS
  664.  
  665. ;        =======================
  666.  
  667. ; NOT and INVERT are synonyms.
  668.  
  669. znot_m    macrox
  670.     NOT.L    (A6)
  671.     endm
  672.  
  673.     head    3,NOT,znot,xinfo,,pm_h        ; NOT
  674.     dc.w    otNOT
  675.     use    znot
  676.  
  677. invert_m    macrox
  678.     not.l    (a6)
  679.     endm
  680.  
  681.     head    6,INVERT,invert,xinfo,,pm_h    ; INVERT
  682.     dc.w    otNOT
  683.     use    invert
  684.  
  685.  
  686. zand_m    macrox
  687.     POP.L    D0
  688.     AND.L    D0,(A6)
  689.     endm
  690.     head    3,AND,zand,xinfo,,pm_h        ; AND
  691.     dc.w    otAND
  692.     use    zand
  693.  
  694.  
  695. zor_m    macrox
  696.     POP.L    D0
  697.     OR.L    D0,(A6)
  698.     endm
  699.     head    2,OR,zor,xinfo,,pm_h        ; OR
  700.     dc.w    otOR
  701.     use    zor
  702.  
  703.  
  704. xor_m    macrox
  705.     POP.L    D0
  706.     EOR.L    D0,(A6)
  707.     endm
  708.     head    3,XOR,xor,xinfo,,pm_h        ; XOR
  709.     dc.w    otEOR
  710.     use    xor
  711.  
  712.  
  713. ; Logical operations directly on a memory byte
  714.  
  715.     head    4,CSET,cset        ; CSET
  716. ; ( c addr -- )  ORs c into the byte at addr.
  717.     POP.L    A0
  718.     POP.L    D0
  719.     OR.B    D0,(A0)
  720.     RTS
  721.  
  722.     head    6,CRESET,creset        ; CRESET
  723. ; ( c addr -- )  Clears bits in byte at addr, corresponding
  724. ; to the bits SET in c.    
  725.     POP.L    A0
  726.     POP.L    D0
  727.     NOT.B    D0
  728.     AND.B    D0,(A0)
  729.     RTS
  730.  
  731.     head    7,CTOGGLE,ctoggle        ; CTOGGLE
  732. ; ( c addr -- )  Exclusive-ORs c into the byte at addr.
  733.     POP.L    A0
  734.     POP.L    D0
  735.     EOR.B    D0,(A0)
  736.     RTS
  737.  
  738.     head    8,CREPLACE,creplace        ; CREPLACE
  739. ; ( c mask addr -- )
  740. ; Replaces bits in the addressed byte with the corresponding
  741. ; bits from c, in those positions where the mask has ones.
  742.     POP.L    A0
  743.     POP.L    D1    ; Mask to D1
  744.     POP.L    D0    ; c to D0
  745.     AND.B    D1,D0
  746.     NOT.B    D1
  747.     AND.B    D1,(A0)    ; Clear masked bits in addressed byte
  748.     OR.B    D0,(A0)    ; Set where set in c
  749.     RTS
  750.  
  751.  
  752. ; Logical operations on a memory bit.  These operations all designate
  753. ; the operand bit by means of an address and a bit number.  The bit number
  754. ; can be greater than 8, and this just takes us to successive bytes to the
  755. ; left.  It seems more logical for the bit number to follow the address,
  756. ; even though this apparently is inconsistent for the operand ordering
  757. ; in CSET etc.  But this isn't a real inconsistency, since the bit number
  758. ; is really an extension of the address, not a separate data item.
  759.  
  760. getbit    pop.l    d0
  761.     pop.l    a0
  762.     move.w    d0,d1
  763.     lsr.w    #3,d1
  764.     sub.w    d1,a0
  765.     rts
  766.     
  767.     head    4,BSET,.bset,xinfo,,bit_h        ; BSET
  768. ; ( addr n -- )  Sets the bit.
  769.     dc.w    tsBset
  770.  
  771. .bset    bsr.s    getbit
  772.     bset    d0,(a0)
  773.     rts
  774.  
  775.     head    6,BRESET,.breset,xinfo,,bit_h    ; BRESET
  776. ; ( addr n -- )  Clears the bit.
  777.     dc.w    tsBreset
  778.  
  779. .breset    bsr.s    getbit
  780.     bclr    d0,(a0)
  781.     rts
  782.  
  783.     head    7,BTOGGLE,.btoggle,xinfo,,bit_h    ; BTOGGLE
  784. ; ( addr n -- )  Toggles the bit.
  785.     dc.w    tsBtoggle
  786.  
  787. .btoggle    bsr.s    getbit
  788.     bchg    d0,(a0)
  789.     rts
  790.  
  791.     head    5,BTEST,.btest,xinfo,,bit_h    ; BTEST
  792. ; ( addr n -- b )
  793.     dc.w    tsBtest
  794.  
  795. .btest    bsr.s    getbit
  796.     btst    d0,(a0)
  797.     bne.s    setTrue
  798.     bra.s    setFalse
  799.  
  800.  
  801. ; Comparisons
  802.  
  803.     head    2,U<,ult        ; U<
  804. xcmp    CMPM.L    (A6)+,(A6)+
  805.     BLO.S    setTrue
  806.     BRA.S    setFalse
  807.  
  808.     head    2,U>,ugt        ; U>
  809.     CMPM.L    (A6)+,(A6)+
  810.     BHI.S    setTrue
  811.     BRA.S    setFalse
  812.  
  813.     head    1,<,lt,docode,tsLT        ; <
  814.     CMPM.L    (A6)+,(A6)+
  815.     BLT.S    setTrue
  816.     BRA.S    setFalse
  817.  
  818.     head    1,>,gt,docode,tsGT        ; >
  819.     CMPM.L    (A6)+,(A6)+
  820.     BGT.S    setTrue
  821.     BRA.S    setFalse
  822.  
  823.     head    1,=,eq,docode,tsEQ        ; =
  824.     CMPM.L    (A6)+,(A6)+
  825.     BNE.S    setFalse
  826.  
  827. setTrue    MOVEQ    #-1,D0
  828.     PUSH.L    D0
  829.     RTS
  830.  
  831.     head    2,<>,ne,docode,tsNE        ; <>
  832.     CMPM.L    (A6)+,(A6)+
  833. pushBool
  834.     BNE.S    setTrue
  835. setFalse
  836.     CLR.L    -(A6)
  837.     RTS
  838.  
  839.     head    2,>=,ge,docode,tsGE        ; >=
  840.     CMPM.L    (A6)+,(A6)+
  841.     BGE.S    setTrue
  842.     BRA.S    setFalse
  843.  
  844.     head    2,<=,le,docode,tsLE        ; <=
  845.     CMPM.L    (A6)+,(A6)+
  846.     BLE.S    setTrue
  847.     BRA.S    setFalse
  848.  
  849.     head    2,0=,zeq,docode,tsZEQ        ; 0=
  850. xtst    TST.L    (A6)+
  851.     BEQ.S    setTrue
  852.     BRA.S    setFalse
  853.  
  854.     head    3,0<>,zne,docode,tsZNE        ; 0<>
  855.     TST.L    (A6)+
  856.     BNE.S    setTrue
  857.     BRA.S    setFalse
  858.  
  859.     head    2,0<,zlt,docode,tsZLT        ; 0<
  860.     TST.L    (A6)+
  861.     BLT.S    setTrue
  862.     BRA.S    setFalse
  863.  
  864.     head    2,0>,zgt,docode,tsZGT        ; 0>
  865.     TST.L    (A6)+
  866.     BGT.S    setTrue
  867.     BRA.S    setFalse
  868.  
  869.     head    3,0<=,zle,docode,tsZLE        ; 0<=
  870.     TST.L    (A6)+
  871.     BLE.S    setTrue
  872.     BRA.S    setFalse
  873.  
  874.     head    3,0>=,zge,docode,tsZGE        ; 0>=
  875.     TST.L    (A6)+
  876.     BGE.S    setTrue
  877.     BRA.S    setFalse
  878.  
  879.  
  880.     head    7,WITHIN?,within,docode,tsCCOK    ; WITHIN?
  881. ; ( n lo hi -- n b )  Returns true if  lo <= n <= hi.
  882.  
  883.     POP.L    D1    ; D1 = hi
  884.     POP.L    D0    ; D0 = lo
  885.     MOVEQ    #0,D2    ; D2 for return result
  886.     CMP.L    (A6),D0
  887.     BGT.S    .end
  888.     CMP.L    (A6),D1
  889.     BLT.S    .end
  890.     MOVEQ    #-1,D2
  891. .end    PUSH.L    D2
  892.     RTS
  893.  
  894.  
  895. ;        ===========================
  896.  
  897. ;            FETCHES AND STORES
  898.  
  899. ;        ===========================
  900.  
  901. at_m    macrox
  902.     move.l    (a6),a0
  903.     move.l    (a0),(a6)
  904.     endm
  905.     head    1,@,at,xinfo,,at_h        ; @
  906.     dc.w    tsAT
  907.     dc.w    0
  908.     use    at
  909.  
  910.  
  911.     head    4,>PTR,.toptr,xinfo,,at_h        ; >PTR
  912.  
  913. ; In our system, this is an alias for @.
  914.  
  915.     dc.w    tsAT
  916.     dc.w    0
  917. .toptr    bra.s    at
  918.  
  919.  
  920. wat_m    macrox
  921.     MOVE.L    (A6),A0
  922.     MOVEQ    #0,D0
  923.     MOVE.W    (A0),D0
  924.     MOVE.L    D0,(A6)
  925.     endm
  926.     head    2,W@,wat,xinfo,,at_h        ; W@
  927.     dc.w    tsWAT
  928.     dc.w    0
  929.     use    wat
  930.  
  931.  
  932. watx_m    macrox
  933.     MOVE.L    (A6),A0
  934.     MOVE.W    (A0),A1    ; Sign-extends
  935.     MOVE.L    A1,(A6)
  936.     endm
  937.     head    3,W@X,watx,xinfo,,at_h        ; W@X
  938.     dc.w    tsWAT
  939.     dc.w    fbExt
  940.     use    watx
  941.  
  942.  
  943. cat_m    macrox
  944.     MOVE.L    (A6),A0
  945.     MOVEQ    #0,D0
  946.     MOVE.B    (A0),D0
  947.     MOVE.L    D0,(A6)
  948.     endm
  949.     head    2,C@,cat,xinfo,,at_h        ; C@
  950.     dc.w    tsCAT
  951.     dc.w    0
  952.     use    cat
  953.  
  954.  
  955. catx_m    macrox
  956.     move.l    (a6),a0
  957.     move.b    (a0),d0
  958.     ext.w    d0
  959.     ext.l    d0
  960.     move.l    d0,(a6)
  961.     endm
  962.     head    3,C@X,catx,xinfo,,at_h        ; C@X
  963.     dc.w    tsCAT
  964.     dc.w    fbExt
  965.     use    catx
  966.  
  967.  
  968. store_m    macrox
  969.     POP.L    A0
  970.     MOVE.L    (A6)+,(A0)
  971.     endm
  972.     head    1,!,store,xinfo,,store_h        ; !
  973.     dc.w    otStore*256 + Lcode
  974.     use    store
  975.  
  976.  
  977. plstore_m    macrox
  978.     POP.L    A0
  979.     POP.L    D0
  980.     ADD.L    D0,(A0)
  981.     endm
  982.     head    2,+!,plstore,xinfo,,store_h    ; +!
  983.     dc.w    otADD*256 + Lcode
  984.     use    plstore
  985.  
  986. mnstore_m    macrox
  987.     POP.L    A0
  988.     POP.L    D0
  989.     SUB.L    D0,(A0)
  990.     endm
  991.  
  992.     head    2,-!,mnstore,xinfo,,store_h    ; -!
  993.     dc.w    otSUB*256 + Lcode
  994.     use    mnstore
  995.  
  996.  
  997. wstore_m    macrox
  998.     pop.l    a0
  999.     addq    #2,a6
  1000.     move.w    (a6)+,(a0)
  1001.     endm
  1002.     head    2,W!,wstore,xinfo,,store_h        ; W!
  1003.     dc.w    otStore*256 + Wcode
  1004.     use    wstore
  1005.  
  1006.  
  1007. wplstore_m    macrox
  1008.     pop.l    a0
  1009.     pop.l    d0
  1010.     add.w    d0,(a0)
  1011.     endm
  1012.     head    3,W+!,wplstore,xinfo,,store_h    ; W+!
  1013.     dc.w    otADD*256 + Wcode
  1014.     use    wplstore
  1015.  
  1016.  
  1017. wmnstore_m    macrox
  1018.     pop.l    a0
  1019.     pop.l    d0
  1020.     sub.w    d0,(a0)
  1021.     endm
  1022.     head    3,W-!,wmnstore,xinfo,,store_h    ; W-!
  1023.     dc.w    otSUB*256 + Wcode
  1024.     use    wmnstore
  1025.  
  1026.  
  1027. cstore_m    macrox
  1028.     POP.L    A0
  1029.     POP.L    D0
  1030.     MOVE.B    D0,(A0)
  1031.     endm
  1032.     head    2,C!,cstore,xinfo,,store_h        ; C!
  1033.     dc.w    otStore*256 + Ccode
  1034.     use    cstore
  1035.  
  1036.  
  1037. ;        ==============================
  1038.  
  1039. ;           RETURN STACK OPERATIONS
  1040.  
  1041. ;        ==============================
  1042.  
  1043. ; Note: we keep the loop index I in D3, but the return stack is entirely
  1044. ; in memory so that words can be called simply with BSR/JSR.  This means that
  1045. ; I can be used in words called from within DO loops.  In fact I can be used
  1046. ; as another local variable.
  1047.  
  1048. i_m    macrox
  1049.     PUSH.L    D3
  1050.     endm
  1051.     head    1,I,i,xinfo,,reg_h        ; I
  1052.     dc.b    mdDn
  1053.     dc.b    3
  1054.     use    i
  1055.  
  1056. j_m    macrox
  1057.     PUSH.L    8(A7)
  1058.     endm
  1059.     head    1,J,j,inline        ; J
  1060.  
  1061. k_m    macrox
  1062.     PUSH.L    20(A7)
  1063.     endm
  1064.     head    1,K,k,inline        ; K
  1065.  
  1066. tor_m    macrox
  1067.     POP.L    -(A7)
  1068.     endm
  1069.     head    2,>R,toR,inline        ; >R
  1070.  
  1071. rfrom_m    macrox
  1072.     PUSH.L    (A7)+
  1073.     endm
  1074.     head    2,R>,Rfrom,inline        ; R>
  1075.  
  1076. ; R and R@ are synonyms.
  1077.  
  1078. r_m    macrox
  1079.     push.l    (a7)
  1080.     endm
  1081.     head    1,R,r,inline        ; R
  1082.  
  1083. rat_m    macrox
  1084.     push.l    (a7)
  1085.     endm
  1086.     head    2,R@,rat,inline        ; R@
  1087.  
  1088.  
  1089. ptrBase_m    macrox
  1090.     PUSH.L    A2
  1091.     endm
  1092.     head    5,^BASE,ptrBase,xinfo,,reg_h    ; ^BASE
  1093.     dc.b    mdAn
  1094.     dc.b    2
  1095.     use    ptrBase
  1096.  
  1097.  
  1098.     head    4,SELF,.self        ; SELF
  1099.  
  1100. ; Note: SELF is not necessarily the same as ^BASE, because of multiple
  1101. ; inheritance.
  1102.  
  1103.     move.l    a2,a0
  1104.     subq    #2,a0
  1105.     add.w    (a0),a0
  1106.     addq    #8,a0
  1107.     push.l    a0
  1108.     rts
  1109.  
  1110.  
  1111. ;        =============================
  1112.  
  1113. ;        MISCELLANEOUS LOW-LEVEL WORDS
  1114.  
  1115. ;        =============================
  1116.  
  1117. spat_m    macrox
  1118.     move.l    a6,-(a6)
  1119.     endm
  1120.     head    3,SP@,spat,xinfo,,reg_h        ; SP@
  1121.     dc.b    mdAn
  1122.     dc.b    6
  1123.     use    spat
  1124.  
  1125.  
  1126. spstore_m    macrox
  1127.     move.l    (a6),a6
  1128.     endm
  1129.     head    3,SP!,spstore,inline        ; SP!
  1130.  
  1131.  
  1132. rpat_m    macrox
  1133.     move.l    a7,-(a6)
  1134.     endm
  1135.     head    3,RP@,rpat,xinfo,,reg_h        ; RP@
  1136.     dc.b    mdAn
  1137.     dc.b    7
  1138.     use    rpat
  1139.  
  1140.  
  1141.     head    3,RP!,rpstore        ; RP!
  1142.     move.l    (a7),a0    ; Save rtn addr
  1143.     clr.l    ExBoffs-base(a3)
  1144.     pop.l    a7
  1145.     moveq    #-1,d0
  1146.     move.l    d0,a2
  1147.     jmp    (a0)
  1148.  
  1149.  
  1150.     head    6,BOUNDS,bounds        ; BOUNDS
  1151.  
  1152. ; ( addr cnt -- limit addr )  Equivalent to OVER + SWAP.  
  1153. ; Useful for setting up many DO loops.
  1154.  
  1155.     move.l    (a6),d0
  1156.     move.l    4(a6),(a6)
  1157.     add.l    d0,4(a6)
  1158.     rts
  1159.  
  1160. here_m    macrox
  1161.     fVal    DP
  1162.     endm
  1163.     head    4,HERE,here,inline        ; HERE
  1164.  
  1165.     head    5,ALLOT,allot        ; ALLOT
  1166.     incVal    DP
  1167.     NoOpt
  1168.     RTS
  1169.  
  1170.     head    4,ROOM,room        ; ROOM
  1171.     parms    DicSize,here
  1172.     LEA    start,A0
  1173.     PUSH.L    A0
  1174.     parms    minus,minus,semis
  1175.  
  1176.     head    6,UNUSED,unused        ; UNUSED
  1177.     bra    room
  1178.  
  1179.     head    8,HEADROOM,.headroom        ; HEADROOM
  1180.     LEA    32766(A4),A0
  1181.     SUB.L    dp,A0
  1182.     PUSH.L    A0
  1183.     RTS
  1184.  
  1185.     head    3,BYE,bye,spec        ; BYE
  1186.     bra    doBye
  1187.  
  1188.     head    4,NULL,null,spec        ; NULL
  1189.     RTS
  1190.  
  1191.     head    5,COUNT,count        ; COUNT
  1192.     bra    doCount
  1193.  
  1194.     head    6,LENGTH,length        ; LENGTH
  1195.     bra    doLength
  1196.  
  1197.     head    5,DEPTH,depth        ; DEPTH
  1198.     bra    doDepth
  1199.  
  1200.     head    5,DIGIT,digit        ; DIGIT
  1201.     bra    doDigit
  1202.  
  1203.     head    7,DECIMAL,decimal        ; DECIMAL
  1204.     MOVE.L    #10,nbase-base(A3)
  1205.     RTS
  1206.  
  1207.     head    3,HEX,hex        ; HEX
  1208.     MOVE.L    #16,nbase-base(A3)
  1209.     RTS
  1210.  
  1211.     head    6,W@(IP),.watIP        ; W@(IP)
  1212.     bra    doWatIP
  1213.  
  1214.     head    5,@(IP),.atIP        ; @(IP)
  1215.     bra    doAtIP
  1216.  
  1217.  
  1218. ; HASH now produces a 32-bit hash value.  We always set the top bit
  1219. ; (so that a hashed value is never zero, and is always distinguishable
  1220. ; from a relocatable address, which is always "positive").
  1221. ; This means that we effectively have 2**31 hash possibilities.  This is
  1222. ; large enough that hash collisions will hardly ever occur.
  1223. ; If a 16-bit hash value is required, as in Neon, use wHash.
  1224.  
  1225.  
  1226.     head    4,HASH,.hash        ; HASH
  1227. ; ( addr -- n )
  1228.     bra    doHash
  1229.  
  1230.     head    5,WHASH,.wHash        ; wHASH
  1231.     bra    doWhash
  1232.  
  1233.  
  1234.     head    5,^ELEM,elem        ; ^ELEM
  1235. ; ( index -- addr )  A2 is ^obj.  Leaves addr of indexed element.
  1236.     bra    doElem
  1237.  
  1238.     head    6,^ELEM1,.elem1        ; ^ELEM1
  1239. ; ( index -- )  As for ^ELEM, but assumes width = 1.  Saves multiplying.
  1240.     bra    doElem1
  1241.  
  1242.  
  1243.     head    6,^ELEM2,.elem2        ; ^ELEM2
  1244.     bra    doElem2
  1245.  
  1246.  
  1247.     head    6,^ELEM4,.elem4        ; ^ELEM4
  1248.     bra    doElem4
  1249.  
  1250.     head    7,IDXBASE,idxbase        ; IDXBASE
  1251.     bra    doIdxBase
  1252.  
  1253.  
  1254.     head    5,LIMIT,.limit        ; LIMIT
  1255.     bsr    doIdxBase
  1256.     move.l    d1,(a6)
  1257.     rts
  1258.  
  1259.  
  1260. lobase_m    macrox
  1261.     push.l    a3
  1262.     endm
  1263.  
  1264. hibase_m    macrox
  1265.     push.l    a4
  1266.     endm
  1267.  
  1268. modbase_m    macrox
  1269.     push.l    a5
  1270.     endm
  1271.  
  1272.     head    6,LOBASE,lobase,xinfo,,reg_h    ; LOBASE
  1273.     dc.b    mdAn
  1274.     dc.b    3
  1275.     use    lobase
  1276.  
  1277.     head    6,HIBASE,hibase,xinfo,,reg_h    ; HIBASE
  1278.     dc.b    mdAn
  1279.     dc.b    4
  1280.     use    hibase
  1281.  
  1282.     head    7,MODBASE,modbase,xinfo,,reg_h    ; MODBASE
  1283.     dc.b    mdAn
  1284.     dc.b    5
  1285.     use    modbase
  1286.  
  1287.  
  1288. ; Multiplication and division.  In this version we dispense with all
  1289. ; double length (64-bit) arithmetic.  This is needed in 16-bit Forths,
  1290. ; but hardly in a 32-bit system.  Not in the nucleus, anyway.  It is
  1291. ; provided in the file LongMath.  SM/REM and FM/MOD are defined there
  1292. ; as well.
  1293.  
  1294.     head    1,*,star,xinfo,,multdiv_h        ; *
  1295.     dc.w    otMUL
  1296.  
  1297. star    bra    SMult    ; NOP'd out if processor > 68000
  1298.     pop.l    d0
  1299.     muls.l    (a6),d0
  1300.     move.l    d0,(a6)
  1301.     rts
  1302.  
  1303.  
  1304.     head    2,*W,starW,xinfo,,multdiv_h    ; *W
  1305.     dc.w    otMUL
  1306.  
  1307. starW    pop.l    d0
  1308.     muls    2(a6),d0
  1309.     move.l    d0,(a6)
  1310.     rts
  1311.  
  1312.  
  1313.     head    1,//,slash,xinfo,,multdiv_h    ; /
  1314.     dc.w    otDIV
  1315.  
  1316. slash    bra    pSlash    ; NOP'd out if processor > 68000
  1317.     pop.l    d2
  1318.     move.l    (a6),d1
  1319.     tdivs.l    d2,d0:d1
  1320.     move.l    d1,(a6)    ; Push quotient
  1321.     rts
  1322.  
  1323.  
  1324.     head    3,MOD,mod        ; MOD
  1325.     bra    pMod    ; NOP'd out if processor > 68000
  1326.     pop.l    d2
  1327.     move.l    (a6),d1
  1328.     tdivs.l    d2,d0:d1
  1329.     move.l    d0,(a6)    ; Push remainder
  1330.     rts
  1331.  
  1332.     head    4,//MOD,slmod        ; /MOD
  1333.     bra    pSlMod    ; NOP'd out if processor > 68000
  1334.     pop.l    d2
  1335.     move.l    (a6),d1
  1336.     tdivs.l    d2,d0:d1
  1337.     move.l    d0,(a6)    ; Push remainder
  1338.     push.l    d1    ; Push quotient
  1339.     rts
  1340.  
  1341.     head    5,U//MOD,uslmod        ; U/MOD
  1342.     bra    pUSlMod    ; NOP'd out if processor > 68000
  1343.     pop.l    d2    ; Divisor
  1344.     move.l    (a6),d1    ; Dividend
  1345.     tdivu.l    d2,d0:d1
  1346.     move.l    d0,(a6)    ; Push remainder
  1347.     push.l    d1    ; Push quotient
  1348.     rts
  1349.  
  1350.     head    5,//MODW,slModW        ; /MODW
  1351.     bra    pSlModW
  1352.  
  1353.     head    6,//UMODW,uSlModW        ; U/MODW
  1354.     bra    pUSlModW
  1355.  
  1356.  
  1357. ; MulX is used to multiply a potentially longword index value by the width of
  1358. ; each indexed element.
  1359. ; D0 = index, D1 = width.  Leaves result in D0.  Uses D2.
  1360.  
  1361.     head    4,MULX,mulx
  1362.     bra    pMulx    ; NOP'd out if processor > 68000
  1363.     mulu.l    d1,d0
  1364.     rts
  1365.  
  1366.  
  1367. ; Copies of the original branches - used by Install to replace the branches
  1368. ; before saving a new nucleus or application.
  1369.  
  1370.     varbl    3,BRS,brs
  1371.     dc.w    $6000,sMult-star-2
  1372.     dc.w    $6000,pSlash-slash-2
  1373.     dc.w    $6000,pMod-mod-2
  1374.     dc.w    $6000,pSlMod-slMod-2
  1375.     dc.w    $6000,pUSlMod-UslMod-2
  1376.     dc.w    $6000,pMulx-mulx-2
  1377.  
  1378.  
  1379. ; Note that */MOD and */ only use a 32-bit intermediate result.
  1380. ; If you need 64 bits, load the file LongMath.
  1381.  
  1382.     head    5,*//MOD,starslmod        ; */MOD
  1383.     move.l    (a6)+,-(a7)
  1384.     bsr    star
  1385.     move.l    (a7)+,-(a6)
  1386.     bra    slMod
  1387.  
  1388.  
  1389.     head    2,*//,starsl        ; */
  1390.     bsr.s    starSlMod
  1391.     pop.l    (a6)
  1392.     rts
  1393.  
  1394.  
  1395. ; Shifts.  << is now a synonym for ANSI LSHIFT, and >> for RSHIFT.
  1396.  
  1397.     head    6,LSHIFT,Lshift,xinfo,,shift_h    ; LSHIFT
  1398.     dc.w    otSHIFT*256
  1399.  
  1400. Lshift    pop.l    d0
  1401.     pop.l    d1
  1402.     lsl.l    d0,d1
  1403.     push.l    d1
  1404.     rts
  1405.  
  1406.     head    2,<<,.shiftL,xinfo,,shift_h    ; <<
  1407.     dc.w    otSHIFT*256
  1408. .shiftL    jmp    Lshift-base(a3)
  1409.  
  1410.  
  1411.     head    6,RSHIFT,Rshift,xinfo,,shift_h    ; RSHIFT
  1412.     dc.w    otSHIFT*256 + 1
  1413.  
  1414. Rshift    pop.l    d0
  1415.     pop.l    d1
  1416.     lsr.l    d0,d1
  1417.     push.l    d1
  1418.     rts
  1419.  
  1420.     head    2,>>,.shiftR,xinfo,,shift_h    ; >>
  1421.     dc.w    otSHIFT*256 + 1
  1422. .shiftR    jmp    Rshift-base(a3)
  1423.  
  1424.  
  1425. ;        ======================
  1426.  
  1427. ;                  I/O
  1428.  
  1429. ;        ======================
  1430.  
  1431.     valu    4,BUSY,busy        ; BUSY
  1432. ; FCB of file involved in asynchronous I/O, or zero if none.
  1433. ; Set from high level, not from here.  Cleared here though,
  1434. ; by the completion routine.
  1435.  
  1436.     valu    6,CPADDR,CPaddr,0        ; CPADDR
  1437. ; Completion routine address, or zero if none.  Also serves
  1438. ; as a flag that the next op is to be asynchronous.
  1439.  
  1440.  
  1441.     head    5,COMPL,compl        ; COMPL
  1442. ; Our completion routine for asynch I/O.  We don't rely on
  1443. ; any regs being set up.  All we have to do is clear BUSY.
  1444.  
  1445.     LEA    busy,A0
  1446.     CLR.L    (A0)
  1447.     RTS
  1448.  
  1449.  
  1450.     head    5,SETCP,asynch        ; SETCP
  1451. ; Sets the completion routine address, making the next
  1452. ; read or write asynchronous.
  1453.  
  1454.     LEA    compl,A0
  1455.     MOVE.L    A0,CPaddr-base(A3)
  1456.     RTS
  1457.  
  1458.  
  1459.     head    6,(MAKE),pmake        ; (MAKE)
  1460.     bra    dopMake
  1461.  
  1462.     head    6,(OPEN),popen        ; (OPEN)
  1463.     bra    dopOpen
  1464.  
  1465.     head    7,(CLOSE),pclose        ; (CLOSE)
  1466.     bra    dopClose
  1467.  
  1468.     head    8,(DELETE),.pdelete        ; (DELETE)
  1469.     bra    dopDelete
  1470.  
  1471.     head    6,(READ),pread        ; (READ)
  1472.     bra    doPread
  1473.  
  1474.     head    7,(WRITE),pwrite        ; (WRITE)
  1475.     bra    doPwrite
  1476.  
  1477.     head    7,(LSEEK),plseek
  1478.     bra    doPlseek
  1479.  
  1480.  
  1481. ;        ===========================
  1482.  
  1483. ;            OTHER SYSTEM CALLS
  1484.  
  1485. ;        ===========================
  1486.  
  1487.  
  1488.     head    5,FINFO,.finfo        ; FINFO
  1489. ; ( -- addr )
  1490. ; NOTE: This is only valid for systems where no AppleEvents are available.
  1491. ; Therefore if they are available, we return a nil pointer.
  1492.  
  1493.     tst.b    AppleEventsQ+3-base(a3)
  1494.     beq.s    .fn1
  1495.     push.l    nilP
  1496.     rts
  1497.  
  1498. .fn1    savA5
  1499.     move.l    $10(a5),a0
  1500.     rstA5
  1501.     push.l    (a0)
  1502.     rts
  1503.  
  1504. word0_m    macrox
  1505.     CLR.W    -(A6)
  1506.     endm
  1507.     head    5,WORD0,word0,inline        ; WORD0
  1508.  
  1509. zpack_m    macrox
  1510.     POP.L    D0
  1511.     ADDQ.L    #2,A6
  1512.     PUSH.W    D0
  1513.     endm
  1514.     head    4,PACK,zpack,inline        ; PACK
  1515.  
  1516.     head    6,UNPACK,.unpk        ; UNPACK
  1517.     bra    doUnpk
  1518.  
  1519. itol_m    macrox
  1520.     POP.W    A0
  1521.     PUSH.L    A0
  1522.     endm
  1523.     head    4,I->L,itol,inline,tsCCOK        ; I->L
  1524.  
  1525.  
  1526. makeint_m    macrox
  1527.     ADDQ.L    #2,A6
  1528.     endm
  1529.     head    7,MAKEINT,makeint,inline        ; MAKEINT
  1530.  
  1531.  
  1532.  
  1533. ; Miscellaneous operations on handles and pointers.  These
  1534. ; are glue routines for various toolbox calls, which are
  1535. ; needed by the HANDLE and PTR classes.  They really should
  1536. ; not be called directly from anywhere else.
  1537.  
  1538.     head    4,NEWP,.newp        ; NEWP
  1539. ; ( n ^ptr -- b )
  1540.     bra    doNewP    ; In nuc0.asm
  1541.  
  1542.  
  1543.     head    4,NEWH,.newH        ; NEWH
  1544. ; ( n -- b )
  1545.     bra    doNewH    ; In nuc0.asm
  1546.  
  1547.  
  1548.     head    3,LOK,.lok        ; LOK
  1549.     bra    doLok
  1550.  
  1551.     head    5,UNLOK,.unlok        ; UNLOK
  1552. ; If the handle is nil, rather than trap, we treat it as a no-op.
  1553. ; This simplifies  each: handlelist  and probably other things
  1554. ; as well.
  1555.     bra    doUnlok
  1556.  
  1557.     head    6,HGETST,.HGetSt        ; HGetSt
  1558. ; ( -- state )
  1559.     bra    doHgetst
  1560.  
  1561.     head    6,HSETST,.HSetSt        ; HSetSt
  1562. ; ( state -- )
  1563.     bra    doHsetst
  1564.  
  1565.     head    5,MVHHI,.mvHhi         ; MvHHi
  1566. ; ( -- b )
  1567.     bra    doMvHhi
  1568.  
  1569.     head    5,KILLP,.killP        ; KillP
  1570.     bra    doKillP
  1571.  
  1572.     head    5,KILLH,.killH        ; KillH
  1573.     bra    doKillH
  1574.  
  1575.  
  1576.     head    5,COPYH,.copyH        ; COPYH
  1577. ; ( ^hdl -- n )
  1578.     bra    doCopyH
  1579.  
  1580.  
  1581.     head    6,GETHSZ,.getHSz        ; GETHSZ
  1582. ; ( -- n )
  1583.     bra    doGetHsz
  1584.  
  1585.  
  1586.     head    6,SETHSZ,.setHSz        ; SETHSZ
  1587. ; ( n -- b )
  1588.     bra    doSetHsize    ; in Nuc0.asm
  1589.  
  1590.  
  1591.     head    4,FREE,.free        ; FREE
  1592.     bra    doFree
  1593.  
  1594.     head    7,FREEBLK,.freeblk        ; FREEBLK
  1595.     bra    doFreeBlk
  1596.  
  1597.  
  1598.     head    6,?EVENT,qevent        ; ?EVENT
  1599.     bra    doQevent
  1600.  
  1601.     head    9,NEXTEVENT,nextEvent        ; NEXTEVENT
  1602.  
  1603. ; ( ^event mask -- b )
  1604. ; We call WaitNextEvent if it's available, otherwise GetNextEvent.
  1605.  
  1606.     bra    doNextEvent
  1607.  
  1608.  
  1609.     head    11,FIND-WINDOW,.fndwnd        ; FIND-WINDOW
  1610.     bra    doFindWindow
  1611.  
  1612.  
  1613.     head    4,BEEP,beep        ; BEEP
  1614.     savA5
  1615.     ADDQ.L    #2,SP
  1616.     _SysBeep    ; (duration:INTEGER)
  1617.     rstA5
  1618.     RTS
  1619.  
  1620.  
  1621. ;    ======= Support for :PROC and ;PROC ========
  1622.  
  1623.  
  1624.     head    9,PROCENTRY,.procentry        ; PROCENTRY
  1625.     move.l    saveEP,a0
  1626.     jsr    (a0)
  1627.  
  1628.     head    8,PROCEXIT,procExit        ; PROCEXIT
  1629.     bra    doProcExit
  1630.  
  1631.  
  1632. ;        =========================
  1633.  
  1634. ;        LOW-LEVEL STRING HANDLING
  1635.  
  1636. ;        =========================
  1637.  
  1638.     head    4,FILL,fill        ; FILL
  1639.     POP.L    D0
  1640. dofill    POP.L    D1
  1641.     POP.L    A0
  1642.     MOVE.L    D1,D2
  1643.     SWAP    D2
  1644.     BRA.S    .lptst
  1645. .loop    MOVE.B    D0,(A0)+
  1646. .lptst    DBRA    D1,.loop
  1647.     DBRA    D2,.loop
  1648. .end    RTS
  1649.  
  1650.     head    5,ERASE,erase        ; ERASE
  1651.     MOVEQ    #0,D0
  1652.     BRA.S    dofill
  1653.  
  1654.  
  1655.     head    6,BLANKS,.blanks        ; BLANKS
  1656.     MOVEQ    #32,D0
  1657.     BRA.S    dofill
  1658.  
  1659.  
  1660.     head    4,(S=),.pseq        ; (S=)
  1661. ; ( addr1 addr2 len -- b )
  1662.     bra    doPseq
  1663.  
  1664.     head    2,S=,.seq        ; S=
  1665. ; ( addr1 len1 addr2 len2 -- b )
  1666.     bra    doSeq
  1667.  
  1668.  
  1669.     head    4,MOVE,move        ; MOVE
  1670.     POP.L    D0
  1671.     POP.L    A1
  1672.     POP.L    A0
  1673.     _BlockMove
  1674.     RTS
  1675.  
  1676.  
  1677.     head    5,CMOVE,cmove        ; CMOVE
  1678.     POP.L    D0
  1679.     POP.L    A1
  1680.     POP.L    A0
  1681.     BRA.S    .lptst
  1682.  
  1683. .loop    MOVE.B    (A0)+,(A1)+
  1684. .lptst    DBRA    D0,.loop
  1685.     RTS
  1686.  
  1687.  
  1688.     head    5,UPPER,upper        ; UPPER
  1689. ; ( addr len -- )
  1690.     bra    doUpper
  1691.  
  1692.  
  1693. ; These words are used by the input parsing section.
  1694.  
  1695. ; SCAN ( addr len c -- addr' len' ) searches the string ( addr len )
  1696. ; for the character c.  addr' is the address of the matching char,
  1697. ; and len' is the remaining length (including the matching char).  If no
  1698. ; match, len' will be zero.
  1699. ;
  1700. ; Class String+ provides a more complete implementation in its
  1701. ; chsearch: method, which has case handling and 32-bit length.
  1702.  
  1703.     head    4,SCAN,scan        ; SCAN
  1704. ; ( addr len -- addr' len' )
  1705.     bra    doScan
  1706.  
  1707.     head    4,SKIP,skip        ; SKIP
  1708.     bra    doSkip
  1709.  
  1710.     head    7,//STRING,slstring        ; /STRING
  1711. ; ( addr len n -- addr' len' )
  1712.     pop.l    d0
  1713.     add.l    d0,4(a6)
  1714.     sub.l    d0,(a6)
  1715.     rts
  1716.  
  1717. ;        ==========================
  1718.  
  1719. ;            INPUT PARSING etc.
  1720.  
  1721. ;        ==========================
  1722.  
  1723.     head    6,SOURCE,source        ; SOURCE
  1724. ; ( -- addr len )
  1725.     move.l    srcstart,d0
  1726.     move.l    toin,d1
  1727.     add.l    d1,d0
  1728.     push.l    d0
  1729.     move.l    srclen,d0
  1730.     sub.l    d1,d0
  1731.     push.l    d0
  1732.     rts
  1733.  
  1734.     head    8,SCAN-SRC,scansrc        ; SCAN-SRC
  1735.  
  1736. ; ( c -- )  Scans the input stream for delimiter c.  Leaves the source
  1737. ; updated to the next character, (so it could be empty if the found char
  1738. ; was the last in the buffer) or overshot if none found (>IN exceeding
  1739. ; SRC-LEN).  The caller will need to check for this.
  1740.  
  1741.     pop.l    d2    ; Save char in D2
  1742.     bsr.s    source
  1743.     push.l    d2
  1744.     bsr    doScan
  1745.     move.l    srclen,d0
  1746.     sub.l    (a6)+,d0
  1747.     addq.l    #1,d0
  1748.     move.l    d0,toin-base(a3)
  1749.     addq.l    #4,a6
  1750.     rts
  1751.  
  1752.  
  1753.     head    8,SKIP-SRC,skipsrc        ; SKIP-SRC
  1754. ; ( c -- )  Skips consecutive delimiters equal to c in the source.
  1755. ; Leaves source updated to the next character, or empty if none.
  1756.  
  1757.     pop.l    d2    ; Save char in D2
  1758.     bsr    source
  1759.     push.l    d2
  1760.     bsr    doSkip
  1761.     move.l    srclen,d0
  1762.     sub.l    (a6)+,d0
  1763.     move.l    d0,toin-base(a3)
  1764.     addq.l    #4,a6
  1765.     rts
  1766.  
  1767.  
  1768.     head    9,SKIP-SRC+,skipsrcpl        ; SKIP-SRC+
  1769.  
  1770. ; ( c -- )  Skips consecutive delimiters equal to c in the source.
  1771. ; If the source gets exhausted before a non-c char is found, keeps
  1772. ; calling REFILL to get more.
  1773.  
  1774.     parms    tor
  1775. .loop    parms    rat,skipsrc
  1776.     move.l    toin,d0
  1777.     cmp.l    srclen-base(a3),d0
  1778.     blt.s    .found
  1779.     bsr    doRefill
  1780.     pop.l    d0
  1781.     bne.s    .loop
  1782.     n    154
  1783.     bra    die
  1784.  
  1785. .found    ADDQ    #4,A7
  1786.     RTS
  1787.  
  1788.  
  1789.     head    5,PARSE,parse        ; PARSE
  1790.  
  1791. ; ( c -- addr len )  Scans the source for delimiter c.  Returns
  1792. ; the addr and len of the parsed string, and updates the source
  1793. ; to the remaining string.
  1794.  
  1795.     move.l    (a6),d1
  1796.     move.l    toin,(a6)
  1797.     push.l    d1
  1798.     parms    scansrc
  1799.     move.l    toin,d0
  1800.     sub.l    (a6),d0
  1801.     subq.l    #1,d0
  1802.     move.l    srcstart,d1
  1803.     add.l    d1,(a6)
  1804.     push.l    d0
  1805.     rts
  1806.  
  1807.  
  1808.     head    10,PARSE-WORD,parsewrd        ; PARSE-WORD
  1809.  
  1810. ; ( c -- addr len )  As for PARSE, but any consecutive initial
  1811. ; delimiters are skipped.  If the input is exhausted in the process,
  1812. ; REFILL is called to get more.
  1813.  
  1814.     parms    dup,skipsrcpl,parse,semis
  1815.  
  1816.  
  1817.     head    13,PARSE-DLM-STR,parseDlmStr    ; PARSE-DLM-STR
  1818.  
  1819. ; ( c -- addr len )  Scans the source for a string delimited at the
  1820. ; start and end by c.  Everything is skipped before the first delimiter.
  1821. ; If the source gets exhausted in the process, REFILL is called to get more.
  1822.  
  1823.     parms    tor
  1824. .loop    parms    r,scansrc
  1825.     move.l    toin,d0
  1826.     cmp.l    srclen-base(a3),d0
  1827.     blt.s    .found
  1828.     bsr    doRefill
  1829.     pop.l    d0
  1830.     bne.s    .loop
  1831.     n    154
  1832.     bra    die
  1833.  
  1834. .found    parms    rfrom,parse,semis
  1835.  
  1836.  
  1837.     head    5,/$22STR/$22,qstrq        ; "STR"
  1838.  
  1839. ; ( -- addr len )  Scans for a string delimited by "..."
  1840.  
  1841.     n    $22
  1842.     parms    parseDlmStr,semis
  1843.  
  1844.  
  1845.     head    5,PLACE,place        ; PLACE
  1846.  
  1847. ; ( addr1 len addr2 -- )  Converts string ( addr1 len )
  1848. ; to a counted string at addr2.  Appends a zero byte.
  1849.  
  1850.     MOVE.L    (A6),A0    ; A0 = addr2
  1851.     MOVE.L    4(A6),D0    ; D0 = len
  1852.     CLR.B    1(A0,D0.L)    ; Append zero byte
  1853.     MOVE.B    D0,(A0)    ; Store count byte
  1854.     parms    onep,swap,cmove,semis
  1855.  
  1856.  
  1857. wdLoc    long
  1858.  
  1859.     head    4,WORD,word        ; WORD
  1860.  
  1861. ; ( c -- addr )  Parses the source using
  1862. ; c as the delimiter (using PARSE-SRC-WORD).  Moves the resulting
  1863. ; string as a counted string to HERE, and returns this address.
  1864.  
  1865. wd1    parms    parsewrd
  1866.     parms    here,aligned
  1867.     MOVE.L    (A6),wdLoc-base(A3)
  1868.     parms    place
  1869.     PUSH.L    wdLoc
  1870.     RTS
  1871.  
  1872.  
  1873.     head    5,WORD",wordq        ; WORD"
  1874. ; ( -- addr )
  1875.     n    $22
  1876.     BRA.S    wd1
  1877.  
  1878.  
  1879.     head    5,MWORD,mword        ; MWORD
  1880.  
  1881. ; ( -- addr )  "Mops word".  Called by DEFINED? which is called
  1882. ; by INTERPRET.
  1883. ; Calls WORD with a blank as delimiter, and converts the string
  1884. ; to upper case.  Leaves counted string at addr (will be HERE).
  1885.  
  1886.     parms    bl,word,dup,count,upper,semis
  1887.  
  1888.  
  1889.     head    4,/$2CSTR,comstr        ; ,STR
  1890. ; ( c -- )  c is delimiter.  Adds the following text until delimiter
  1891. ; to the dictionary as a counted string.
  1892.     parms    parse
  1893. comStr1
  1894.     parms    tuck,here,place,onep,aligned
  1895.     parms    allot,semis
  1896.  
  1897.  
  1898.     head    8,/$2CDLM-STR,comDlmStr        ; ,DLM-STR
  1899.  
  1900. ; ( c -- )  Scans the source for a string delimited at the
  1901. ; start and end by c, then adds it to the dictionary.
  1902.  
  1903.     parms    parseDlmStr
  1904.     BRA.S    comStr1
  1905.  
  1906.  
  1907.     head    2,/$2C/$22,comq        ; ,"
  1908. ; Add text till " to the dictionary.
  1909.     n    $22
  1910.     parms    comstr,semis
  1911.  
  1912.  
  1913.     head    6,/$2C/$22STR/$22,comqstrq    ;     ,"STR"
  1914. ; Adds text delimited by " at the start and end.
  1915.     n    $22
  1916.     parms    comDlmStr,semis
  1917.  
  1918.  
  1919.     head    9,(LIT-STR),plitstr,spec        ; (LIT-STR)
  1920.  
  1921. ; ( -- addr len )
  1922.  
  1923. ; (LIT-STR) is called from any word that needs to be
  1924. ; followed by a literal character string which has a
  1925. ; length byte at the start.
  1926. ; (LIT-STR) expects the top cell of the return stack
  1927. ; to point to the length byte, and this cell is incremented
  1928. ; to point to the next instruction following the string.
  1929.  
  1930.     bra    doPlitstr
  1931.  
  1932.  
  1933.     nohead    pquote,docol,,callStr_h        ; (")
  1934.             ; Just compiles a normal call,
  1935.             ; but special handler code makes
  1936.             ; decompilation easier.
  1937.     parms    plitstr,semis
  1938.  
  1939.  
  1940.     nohead    pdotq,docol,,callStr_h        ; (.")
  1941.     parms    plitstr
  1942.     bsr    type
  1943.     parms    semis
  1944.  
  1945.  
  1946.     head    $41,/$22,quote        ; "
  1947.     tst.l    state-base(A3)
  1948.     beq.s    .intrp
  1949.     compyl    pquote
  1950.     parms    comq,pexit
  1951. .intrp    n    $22
  1952.     parms    parse,semis
  1953.  
  1954.     head    $42,S/$22,.Squote        ; S"
  1955.     bra.s    quote    ; ANSI synonym for "
  1956.  
  1957.  
  1958.     head    $42,./$22,.dotq        ; ."
  1959.     compyl    pdotq
  1960.     parms    comq,semis
  1961.  
  1962.     head    $42,.(,.dotp        ; .(
  1963.     n    $29
  1964.     parms    parse
  1965.     JSR    type-base(A3)    ; Forward
  1966.     parms    semis
  1967.  
  1968.     head    $41,(,.lparen        ; (
  1969.     n    $29
  1970.     parms    parse,twodrop,semis
  1971.  
  1972.     head    $41,\,.bslash,spec        ; \
  1973.     CLR.L    srclen-base(A3)
  1974.     RTS
  1975.  
  1976.  
  1977. ;        ======================
  1978.  
  1979. ;            SCREEN OUTPUT
  1980.  
  1981. ;        ======================
  1982.  
  1983. ; We put some higher-level words first since they are
  1984. ; vectored, and called by some of the lower-level words.
  1985.  
  1986.  
  1987.     head    4,EMIT,emit        ; EMIT
  1988.     parms    dup,emitvec,pemitvec
  1989.     ADDQ.L    #1,out-base(A3)
  1990.     rts
  1991.  
  1992.  
  1993.     head    10,EMITCYCLES,emitCycles        ; EMITCYCLES
  1994.     parms    swap
  1995.     n    0
  1996.     qdo_m    .end
  1997. .loop    parms    dup,emit
  1998.     loop_m    .loop
  1999. .end    parms    drop,semis
  2000.  
  2001.  
  2002.     head    4,TYPE,type        ; TYPE
  2003.     parms    dup
  2004.     incVal    out
  2005.     parms    twodup,typevec,ptypevec,semis
  2006.  
  2007.  
  2008.     head    2,CR,cr        ; CR
  2009.     parms    crvec,pcrvec,semis
  2010.  
  2011.  
  2012.     head    5,SPACE,space        ; SPACE
  2013.     parms    bl,emit,semis
  2014.  
  2015.  
  2016.     head    6,SPACES,spaces        ; SPACES
  2017.     parms    bl,emitcycles,semis
  2018.  
  2019.  
  2020.     head    5,+ECHO,plecho        ; +ECHO
  2021.     ClrVect    echovec
  2022.     ClrVect    emitvec
  2023.     ClrVect    typevec
  2024.     ClrVect    crvec
  2025.     rts
  2026.  
  2027.     head    5,-ECHO,mnecho        ; -ECHO
  2028.     setVect    drop,echovec
  2029.     setVect    drop,emitvec
  2030.     setVect    twodrop,typevec
  2031.     setVect    null,crvec
  2032.     rts
  2033.  
  2034.  
  2035.     head    5,+CURS,plcurs,spec        ; +CURS
  2036.     MOVEQ    #-1,D0
  2037.     MOVE.L    D0,curs-base(A3)
  2038.     RTS
  2039.  
  2040.     head    5,-CURS,mncurs,spec        ; -CURS
  2041.     zVal    curs
  2042.     RTS
  2043.  
  2044.  
  2045. ; Now the low-level stuff:
  2046.  
  2047.     head    4,HOME,home,spec        ; HOME
  2048.     savA5
  2049. gohome    MOVE.L    #$F0008,-(SP)
  2050.     _MoveTo    ; (h,v:INTEGER)
  2051.     rstA5
  2052.     RTS
  2053.  
  2054.  
  2055.     head    3,CLS,cls,spec        ; CLS
  2056.     savA5
  2057.     PEA    FpRect
  2058.     _EraseRect    ; (r:Rect)
  2059.     bra.s    gohome
  2060.  
  2061.  
  2062.     head    6,SCROLL,scroll        ; SCROLL
  2063.     bra    DoScroll
  2064.  
  2065.     head    7,>ORIGIN,ToOrigin        ; >ORIGIN
  2066.     savA5
  2067.     MOVE.L    (SP)+,D0
  2068.     MOVE    D0,(SP)
  2069.     _SetOrigin    ; (h,v:INTEGER)
  2070.     rstA5
  2071.     RTS
  2072.  
  2073.  
  2074.     head    6,GOTOXY,gotoXY        ; GOTOXY
  2075.     savA5
  2076.     MOVE.L    (SP)+,D0
  2077.     MOVE    D0,(SP)
  2078.     _MoveTo    ; (h,v:INTEGER)
  2079.     rstA5
  2080.     RTS
  2081.  
  2082.  
  2083.     head    3,@XY,atXY        ; @XY
  2084.     bra    doAtXY
  2085.  
  2086.  
  2087.     head    4,LINE,line        ; LINE
  2088.     savA5
  2089.     MOVE.L    (SP)+,D0
  2090.     MOVE    D0,(SP)
  2091.     _Line    ; (dh,dv:INTEGER)
  2092.     rstA5
  2093.     RTS
  2094.  
  2095.  
  2096.     head    7,THEPORT,thePort        ; THEPORT
  2097.     savA5
  2098.     MOVE.L    (A5),A0
  2099.     rstA5
  2100.     PUSH.L    (A0)
  2101.     RTS
  2102.  
  2103.  
  2104.     head    4,.CUR,dotcur,spec        ; .CUR
  2105.     savA5
  2106.     bsr    DrawCurs
  2107.     rstA5
  2108.     RTS
  2109.  
  2110.  
  2111.     head    6,(EMIT),pemit        ; (EMIT)
  2112.     bra    DoPemit
  2113.  
  2114.     head    6,(TYPE),ptype        ; (TYPE)
  2115.     bra    DoPtype
  2116.  
  2117.     head    7,CONTBOT,contbot        ; CONTBOT
  2118.     parms    thePort
  2119.     add_m    160    ; $A0
  2120.     parms    wat,semis
  2121.  
  2122.     head    7,CONTTOP,conttop        ; CONTTOP
  2123.     parms    thePort
  2124.     add_m    156    ; $9C
  2125.     parms    wat,semis
  2126.  
  2127.     head    5,#LEAD,qlead        ; #LEAD
  2128.     bra    DoQlead
  2129.  
  2130.     head    6,#LINES,qlines        ; #LINES
  2131.     parms    contbot,conttop,minus,qlead
  2132.     parms    slash,onem,semis
  2133.  
  2134.     head    6,BOTTOM,bottom        ; BOTTOM
  2135.     parms    qlead,qlines,onem,star
  2136.     n    15
  2137.     parms    plus,conttop,plus,semis
  2138.  
  2139.     head    4,(CR),pcr        ; (CR)
  2140.     bra    DoPcr
  2141.  
  2142.     head    4,(BS),pbs        ; (BS)
  2143.     bra    DoPbs
  2144.  
  2145.  
  2146. ;    ===============================
  2147.  
  2148. ;        KEYBOARD INPUT
  2149.  
  2150. ;    ===============================
  2151.  
  2152.  
  2153.     head    9,?TERMINAL,qterminal        ; ?TERMINAL
  2154.     n    $28
  2155.     parms    qevent,semis
  2156.  
  2157.  
  2158.     head    5,(KEY),pkey        ; (KEY)
  2159.     bra    DoPkey
  2160.  
  2161.  
  2162.     head    6,(KEY!),pkeyst        ; (KEY!)
  2163. ; Default for KEY!
  2164.  
  2165.     SetVect    pkey,key
  2166.     parms    plecho,plcurs,semis
  2167.  
  2168.  
  2169. AcceptLim    long    ; Saves length parameter passed to ACCEPT
  2170.  
  2171.  
  2172.     head    6,ACCEPT,accept        ; ACCEPT
  2173.     bra    DoAccept
  2174.  
  2175.  
  2176.     head    10,SET_SOURCE,setsource        ; SET_SOURCE
  2177.     move.l    tib,srcstart-base(a3)
  2178.     move.l    ntib-base(a3),srclen-base(a3)
  2179.     clr.l    toin-base(a3)
  2180.     rts
  2181.  
  2182.  
  2183.     head    5,QUERY,query        ; QUERY
  2184.     parms    tib
  2185.     n    TIBlen
  2186.     parms    accept,drop,setsource
  2187.     clr.l    sourceID-base(a3)
  2188.     rts
  2189.  
  2190.  
  2191.     head    6,REFILL,refill        ; REFILL
  2192.     bra    doRefill
  2193.  
  2194.  
  2195. ;        =====================
  2196.  
  2197. ;            NUMBER INPUT
  2198.  
  2199. ;        =====================
  2200.  
  2201.  
  2202.     head    7,>NUMBER,toNumber        ; >NUMBER
  2203. ; ( ud1 addr1 len1 -- ud2 addr2 len2 )
  2204.     bra    doToNumber
  2205.  
  2206.  
  2207.     head    9,?NOTFOUND,qnotfound        ; QNOTFOUND
  2208.     pop.l    d0
  2209.     bne.s    .out
  2210.     n    -13
  2211.     bra    die    ; "Undefined word"
  2212.  
  2213. .out    rts
  2214.  
  2215.  
  2216.     head    6,NUMBER,number        ; NUMBER
  2217.     bsr    count
  2218.     bsr    doNumq
  2219.     parms    qnotfound,semis
  2220.  
  2221.  
  2222.     head    $47,LITERAL,literal        ; LITERAL
  2223.     callh    hLiteral
  2224.     RTS
  2225.  
  2226.  
  2227. ;        =============================
  2228.  
  2229. ;                NUMBER OUTPUT
  2230.  
  2231. ;        =============================
  2232.  
  2233.     head    4,HOLD,hold        ; HOLD
  2234.     move.l    hld,a0
  2235.     pop.l    d0
  2236.     move.b    d0,-(a0)
  2237.     move.l    a0,hld-base(a3)
  2238.     rts
  2239.  
  2240.     head    2,<#,bdigs        ; <#
  2241.     move.l    pad,hld-base(a3)
  2242.     rts
  2243.  
  2244.     head    2,#>,edigs        ; #>
  2245.     bra    doEdigs
  2246.  
  2247.     head    4,SIGN,sign        ; SIGN
  2248.     bra    doSign
  2249.  
  2250.     head    1,#,dig        ; #
  2251.     bra    doDig
  2252.  
  2253.     head    2,#S,digs        ; #S
  2254. .1    bsr    doDig
  2255.     tst.l    4(a6)
  2256.     bne.s    .1
  2257.     rts
  2258.  
  2259.     head    2,.R,dotr        ; .R
  2260.     bra    doDotr
  2261.  
  2262.     head    1,.,dot        ; .
  2263.     n    0
  2264.     parms    dotr,space,semis
  2265.  
  2266.     head    2,U.,udot        ; U.
  2267.     bra    doUdot
  2268.  
  2269.  
  2270.     head    7,N>COUNT,ntocount        ; N>COUNT
  2271.     parms    count
  2272.     ANDI.B    #$3F,3(A6)
  2273.     rts
  2274.  
  2275.  
  2276. ;    ===========================
  2277.  
  2278. ;        DISK INPUT
  2279.  
  2280. ;    ===========================
  2281.  
  2282. ; This is an interim scheme, used until the File class can be
  2283. ; loaded.  Thus it doesn't need to be very efficient.
  2284.  
  2285.  
  2286.     head    5,!FPTR,stfptr        ; !FPTR
  2287. ; ( ^filename fcb -- )
  2288.     add_m    18
  2289.     parms    store,semis
  2290.  
  2291. DiskBuf    byte 10
  2292.  
  2293.     head    6,(DKEY),pdkey        ; (DKEY)
  2294.     bra    doPdkey
  2295.  
  2296.     head    2,<",ltq        ; <"
  2297.     bra    doLtq
  2298.  
  2299.     head    3,-<",.mltq        ; -<"
  2300.     parms    mnecho,ltq,semis
  2301.  
  2302.  
  2303. ;    =============================
  2304.  
  2305. ;        APPLEEVENTS
  2306.  
  2307. ;    =============================
  2308.  
  2309.     head    9,AEHANDLER,AEhandler
  2310.  
  2311. ; ( ^AE ^AEReply RefCon -- )
  2312.  
  2313. ; Put at the start of an AppleEvent handler proc.  Pops the parms into
  2314. ; the appropriate locations.
  2315.  
  2316.     bra    doAEhandler
  2317.  
  2318.     
  2319.     head    11,GOTPARMS?,GotParmsq
  2320.  
  2321. ; ( -- rc )
  2322.  
  2323. ; This can be called at the end of a handler, to check if we got all
  2324. ; the parameters.
  2325.  
  2326.     bra    doGotParmsq
  2327.  
  2328.  
  2329.     head    13,?RTNAEPMISSED,qRtnAEPmissed
  2330.  
  2331. ; ( w:xx rc -- w:rc' )
  2332.  
  2333. ; This can be called after calling GotParms? to convert the return code
  2334. ; from that word to the appropriate return code to return to the caller
  2335. ; of the handler.  If GotParms? returns false, that means we missed
  2336. ; a parm, so we return -1715.  If GotParms? returned anything non-zero,
  2337. ; that means we got all the parms, so we return zero.
  2338.  
  2339.     tst.l    (a6)+
  2340.     beq.s    .err
  2341.     clr.w    (a6)
  2342.     rts
  2343.  
  2344. .err    move.w    #-1715,(a6)    ; errAEParamMissed
  2345.     rts
  2346.  
  2347.  
  2348. ;        ========================
  2349.  
  2350. ;            ERROR CHECKING
  2351.  
  2352. ;        ========================
  2353.  
  2354.     head    5,CATCH,catch        ; CATCH
  2355.     bra    doCatch
  2356.  
  2357.     head    5,THROW,throw        ; THROW
  2358.     bra    doThrow
  2359.  
  2360. ; SAVE_ERR ( addr len -- ) saves all the info needed for an error dump, for use
  2361. ; by the default error-interception routine, so that THROW can be called
  2362. ; without our having to know if a non-default error-interception routine is
  2363. ; installed or not.  addr and len specifies an error text string.
  2364.  
  2365.     head    8,SAVE_ERR,.svErr        ; SAVE_ERR
  2366.     bra    doSvErr
  2367.  
  2368. ; .ERR displays the error info saved by SAVE_ERR.
  2369.  
  2370.     head    4,.ERR,dotErr        ; .ERR
  2371.     bra    doDotErr
  2372.  
  2373.  
  2374.     head    5,ABORT,abort        ; ABORT
  2375.     n    0
  2376.     n    0
  2377.     bsr    doSvErr
  2378.     n    -1
  2379.     bra    doThrow
  2380.  
  2381.     head    5,(AB/$22),pabq,docol,,callStr_h    ; (AB")
  2382.     bra    doPabq
  2383.  
  2384.     head    $46,ABORT",.abortq        ; ABORT"
  2385.     JSR    qcomp-base(A3)    ; Forward
  2386.     compyl    pabq
  2387.     parms    comq,semis
  2388.  
  2389. svErrNum    long
  2390.  
  2391.     head    3,DIE,die        ; DIE
  2392.     move.l    (a6),svErrNum-base(a3)
  2393.     n    -1    ; Indicates to SvErr that this is
  2394.     bsr    doSvErr    ;  an err#
  2395.     push.l    svErrNum
  2396.     bra    throwWithInfo
  2397.  
  2398.  
  2399.     head    8,DFLT-ERR,dfltErr        ; DFLT-ERR
  2400.     bra    doDfltErr
  2401.  
  2402.  
  2403.     head    5,?COMP,qcomp        ; ?COMP
  2404.     move.l    state,d0
  2405.     bne.s    qcOut
  2406.     n    -14
  2407.     bra    die    ; "Interpreting a compile-only word"
  2408.  
  2409. qcOut    rts
  2410.  
  2411.     head    6,?STACK,qstack        ; ?STACK
  2412.     bra    doQstack
  2413.  
  2414.     head    5,?EXEC,qexec        ; ?EXEC
  2415.     move.l    state,d0
  2416.     beq.s    qcOut
  2417.     n    77
  2418.     bra    die    ; "Execution state only"
  2419.  
  2420.     head    6,?PAIRS,qpairs        ; ?PAIRS
  2421.     pop.l    d0
  2422.     sub.l    (a6)+,d0
  2423.     beq.s    qprsOut
  2424.     n    -22
  2425.     bra    die    ; "Control structure mismatch"
  2426.  
  2427. qprsOut    rts
  2428.  
  2429.     head    5,?DEFN,qdefn        ; ?DEFN
  2430.     pop.l    d0
  2431.     sub.l    (a6)+,d0
  2432.     beq.s    qprsOut
  2433.     n    78
  2434.     bra    die    ; "Unbalanced definition"
  2435.  
  2436.  
  2437.     head    4,$CHK,.strchk        ; $CHK
  2438.  
  2439. ; Checks the current string object for legality.
  2440. ; Checks that POS and LIM are within the string, and that
  2441. ; POS is not past LIM.  A2 points to the string object.
  2442. ; The offsets are:
  2443. ;
  2444. ;     4    size of string    (long)
  2445. ;     8    POS    (long)
  2446. ;    12    LIM    (long)
  2447.  
  2448.     MOVE.L    4(A2),D0    ; D0 = size
  2449.     CMP.L    8(A2),D0
  2450.     BLO.S    strFail    ; Unsigned chk means negative will fail too,
  2451.     CMP.L    12(A2),D0    ;  which is what we want
  2452.     BLO.S    strFail
  2453.     LEA    8(A2),A0
  2454.     CMPM.L    (A0)+,(A0)+
  2455.     BLO.S    strFail
  2456.     RTS
  2457.  
  2458.  
  2459.     head    5,$FAIL,strFail        ; $FAIL
  2460.  
  2461.     PUSH.L    12(A2)    ; Push LIM
  2462.     PUSH.L    8(A2)    ; Push POS
  2463.     PUSH.L    4(A2)    ; Push SIZE
  2464.     ExVec    strErr    ; Forward - vector
  2465.     _debugger    ; We shouldn't get here?!
  2466.  
  2467.     
  2468.  
  2469. ;    =====================================
  2470.  
  2471. ;        DICTIONARY OPERATIONS
  2472.  
  2473. ;    =====================================
  2474.  
  2475. ; Note: , w, and c, don't change D0, A0 or A1.  IN HANDLERS WE RELY ON THIS.
  2476.  
  2477.     head    1,/$2C,comma        ; ,
  2478.     MOVE.L    A0,-(A7)
  2479.     MOVE.L    DP-base(A3),A0
  2480.     MOVE.L    (A6)+,(A0)
  2481.     ADDQ.L    #4,DP-base(A3)
  2482.     MOVE.L    ODaddr,A0
  2483.     CLR.W    (A0)
  2484.     MOVE.L    (A7)+,A0
  2485.     RTS
  2486.  
  2487.     head    2,W/$2C,wcomma        ; W,
  2488.     MOVE.L    A0,-(A7)
  2489.     MOVE.L    DP-base(A3),A0
  2490.     POP.L    D1
  2491.     MOVE.W    D1,(A0)
  2492.     ADDQ.L    #2,DP-base(A3)
  2493.     MOVE.L    ODaddr,A0
  2494.     CLR.W    (A0)
  2495.     MOVE.L    (A7)+,A0
  2496.     RTS
  2497.  
  2498.     head    2,C/$2C,ccomma        ; C,
  2499.     MOVE.L    A0,-(A7)
  2500.     MOVE.L    DP-base(A3),A0
  2501.     POP.L    D1
  2502.     MOVE.B    D1,(A0)
  2503.     ADDQ.L    #1,DP-base(A3)
  2504.     MOVE.L    ODaddr,A0
  2505.     CLR.W    (A0)
  2506.     MOVE.L    (A7)+,A0
  2507.     RTS
  2508.  
  2509.     head    2,N/$2C,ncomma        ; N,
  2510.     parms    tor,here,r,cmove,rfrom,allot
  2511.     parms    semis
  2512.     
  2513.  
  2514.     head    5,ALIGN,align        ; ALIGN
  2515.     move.l    dp-base(a3),d0
  2516.     moveq    #1,d1
  2517.     and.b    d0,d1
  2518.     add.l    d1,d0
  2519.     move.l    d0,dp-base(a3)
  2520.     rts
  2521.  
  2522. ; Align-DP is a synonym for backwards compatibility.
  2523.  
  2524.     head    8,ALIGN-DP,alignDP        ; ALIGN-DP
  2525.     bra    align
  2526.  
  2527.  
  2528.     head    8,(FORGET),pforget        ; (FORGET)
  2529. ; ( lfa -- )
  2530.     bra    doPforget
  2531.  
  2532.  
  2533.     head    6,FORGET,.forget        ; FORGET
  2534.     JSR    tick-base(A3)    ; Fwd ref
  2535.     parms    tolink,pforget,semis
  2536.  
  2537.  
  2538. ;    ================================
  2539.  
  2540. ;    CONVERSION BETWEEN RELATIVE AND
  2541. ;          ABSOLUTE ADDRESSES
  2542.  
  2543. ;    ================================
  2544.  
  2545. ;    head    4,>B&D,toBandD        ; >B&D
  2546. ; ( addr -- breg displ )
  2547.  
  2548. ; Uses D0,D1 and A1.  Doesn't use A0 as caller needs it.
  2549. ; Leaves module's addressing base in A1, if any.
  2550. ; Leaves breg in D1.
  2551.  
  2552. ;    bra    doToBandD
  2553.  
  2554.  
  2555.     head    8,>B&DCOMP,.toBandDcomp        ; >B&DCOMP
  2556. ; Used by the assembler when generating a b-d address.  The
  2557. ; client's modbase value is in MBcomp, so we use that instead
  2558. ; of the current A5.
  2559.  
  2560.     bra    doToBandDComp
  2561.  
  2562. noRelChk
  2563.     dc.b    0
  2564. noAbsErr
  2565.     dc.b    0
  2566.     align
  2567.  
  2568.  
  2569.     head    6,RELOC!,relocSt        ; RELOC!
  2570.  
  2571. ; ( src dst -- )  Converts the src addr to relocatable and
  2572. ; stores it in the destination.
  2573.  
  2574.     bra    doRelocSt
  2575.  
  2576.  
  2577.     head    6,RELOC/$2C,relocComma        ; RELOC,
  2578.     parms    here,relocSt
  2579.     n    4
  2580.     parms    allot,semis
  2581.  
  2582.  
  2583. pAtAbs    bra    doPAtAbs
  2584.  
  2585.     head    4,@ABS,atAbs        ; @ABS
  2586. ; ( ^reloc-addr -- abs-addr )
  2587.     move.l    (a6),a0
  2588.     bsr    doPAtAbs
  2589.     move.l    a0,(a6)
  2590.     rts
  2591.  
  2592.     head    9,RELOCTYPE,.relocType    ; RelocType
  2593.  
  2594. ; ( ^reloc-addr - n )
  2595.  
  2596. ; Returns the relocation type of the given relocatable addr.
  2597. ; 0 = main dic, 1 = in a module (a5-relative), 2 = in a module (self-relative).
  2598.  
  2599.     bra    doRelocType
  2600.  
  2601.  
  2602.     head    8,DISPLACE,displace        ; DISPLACE
  2603. ; ( addr -- addr' )
  2604.     MOVE.L    (A6),A0
  2605.     MOVE.L    (A0),D0
  2606.     BEQ.S    dplnone
  2607.     ADD.L    D0,(A6)
  2608.     RTS
  2609.  
  2610. dplnone    CLR.L    (A6)
  2611.     RTS
  2612.  
  2613.  
  2614.     head    9,WDISPLACE,.Wdisplace        ; WDISPLACE
  2615. ; ( addr -- addr' )
  2616.     MOVE.L    (A6),A0
  2617.     MOVE.W    (A0),D0
  2618.     BEQ.S    dplnone
  2619.     EXT.L    D0
  2620.     ADD.L    D0,(A6)
  2621.     RTS
  2622.  
  2623.  
  2624.     head    6,DISPL!,.displSt        ; DISPL!
  2625. ; ( src dst -- )  Stores the source address as a relative
  2626. ; address at the destination.
  2627.     pop.l    a0
  2628.     pop.l    d0
  2629.     sub.l    a0,d0
  2630.     move.l    d0,(a0)
  2631.     rts
  2632.  
  2633.  
  2634.     head    7,WDISPL!,.WdisplSt        ; WDISPL!
  2635. ; ( src dst -- )  Stores the source address as a short relative
  2636. ; address at the destination (it is relative to the destination).
  2637.     pop.l    a0
  2638.     pop.l    d0
  2639.     sub.l    a0,d0
  2640.     move.w    d0,(a0)
  2641.     rts
  2642.  
  2643.  
  2644.     head    6,DISPL/$2C,.displCom        ; DISPL,
  2645. ; ( src -- )
  2646.     move.l    dp,d0
  2647.     sub.l    d0,(a6)
  2648.     parms    comma
  2649.     rts
  2650.  
  2651.  
  2652. ;    ==================================
  2653.  
  2654. ;    GLUE WORDS INTERFACING TO HANDLERS
  2655.  
  2656. ;    ==================================
  2657.  
  2658.     head    8,COMPCALL,.compCall        ; CompCall
  2659.     jumph    call_h
  2660.  
  2661.     head    7,DEFNEND,.defnEnd        ; DefnEnd
  2662.     jumph    hDefnEnd
  2663.  
  2664.     head    8,LIT-ADDR,.litAd        ; LIT-ADDR
  2665.     jumph    litAddr
  2666.  
  2667.     head    7,GENADDR,.genaddr        ; GENADDR
  2668.     jumph    hgenaddr
  2669.  
  2670.     head    8,GENXADDR,.genxaddr        ; GENXADDR
  2671.     jumph    hgenxaddr
  2672.  
  2673.     head    6,LOADBA,.loadBA        ; LoadBA
  2674.     jumph    hLoadBA
  2675.  
  2676.     head    6,MENTRY,.Mentry        ; Mentry
  2677.     jumph    hmentry
  2678.  
  2679.     head    7,PLENTRY,.plentry        ; PLENTRY
  2680.     jumph    hplentry
  2681.  
  2682.     head    2,EB,.EB        ; EB
  2683.     jumph    heb
  2684.  
  2685.     head    6,STKOBJ,.EBstk        ; STKOBJ
  2686.     jumph    hStkObj
  2687.  
  2688.     head    $42,EX,.ex        ; EX
  2689.     jumph    hDoEx
  2690.  
  2691.     head    7,(PATCH),.ppatch        ; (PATCH)
  2692.     callh    hPatch
  2693.     bra    patchesDone
  2694.  
  2695. ;    head    6,CALLBA,.callBA        ; CallBA
  2696. ;    jumph    hCallBA
  2697.  
  2698.  
  2699. ; LocParm and FlocParm are dummy words whose cfa is returned by FIND if the
  2700. ; symbol is a parameter or local variable.  (FlocParm is used for floating
  2701. ; quantities).  When we then try to compile this word, its handler LOC_H
  2702. ; or FLOC_H is called, which does all the real work.  It picks up the
  2703. ; lv/p number from LOC# (where it was put by PFind) and compiles the right
  2704. ; code.
  2705.  
  2706.     head    7,LOCPARM,.locparm,nocode,,loc_h
  2707. ; and we don't need anything here!!
  2708.  
  2709.  
  2710.     head    8,FLOCPARM,.flocparm,nocode,,Floc_h
  2711.  
  2712.  
  2713.     head    7,COMPIMP,.compImp        ; CompIMP
  2714.     jumph    hcompimp
  2715.  
  2716.  
  2717.     head    8,COMPFPUL,.compFPUL        ; CompFPUL
  2718.     jumph    hcompFPUL
  2719.  
  2720.  
  2721. ;    ========================================
  2722.  
  2723. ;    LOW-LEVEL SUPPORT FOR VARIOUS CONSTRUCTS
  2724.  
  2725. ;    ========================================
  2726.  
  2727.     head    5,(SEL),.psel        ; (SEL)
  2728.  
  2729.     pop.l    d0    ; D0 = index
  2730.     move.l    (a7),a0    ; Return addr
  2731.     move.w    (a0),d1    ; D1 = offset to end of table
  2732.     add.w    d1,a0    ; Update RA
  2733.     move.l    a0,(a7)    ;  and store back
  2734.     cmp.w    -2(a0),d0
  2735.     bls.s    .ps1
  2736. .psDf    moveq    #-1,d0    ; Use default
  2737. .ps1    add.w    d0,d0
  2738.     neg.w    d0
  2739.     move.w    -6(a0,d0.w),d1    ; Get offset to action stub, using index
  2740.     jmp    0(a0,d1.w)    ; Away we go.  Don't change this 
  2741.             ;  instruction or the debugger won't
  2742.             ;  like it.
  2743.  
  2744.  
  2745. ; Module entry
  2746.  
  2747.     head    8,MODENTRY,modentry        ; MODENTRY
  2748.  
  2749. ; D2 = entry point index
  2750. ; A1 = addr of module object
  2751.  
  2752.     bra    doModEnt
  2753.  
  2754.     head    10,?UNHOLDMOD,.qUnHoldMod
  2755.     bra    doQUnHoldMod
  2756.  
  2757.     head    5,EBMOD,EBmod
  2758.     bra    doEBmod
  2759.  
  2760.  
  2761. ;    ==================================
  2762.  
  2763. ;        DICTIONARY LOOKUP
  2764.  
  2765. ;    ==================================
  2766.  
  2767. boffs    long
  2768. hashval    long
  2769. pFindmRunning    ; Set NZ while (findm) is running, so we can give
  2770.     byte    ; a proper error message if we get an illegal
  2771.     ; relocatable address.
  2772. pFindRunning
  2773.     byte    ; Similarly for Find, if an odd addr trap occurs.
  2774.     align
  2775.  
  2776.  
  2777.     head    6,THREAD,thread        ; THREAD
  2778.  
  2779. ; ( str-addr -- thread-addr )
  2780.  
  2781.     bra    doThread
  2782.  
  2783.  
  2784.     head    6,(FIND),pfind        ; (FIND)
  2785.  
  2786. ; ( string-addr lfa -- cfa flag | -- string-addr false )
  2787.  
  2788. ; lfa points to the dictionary entry where the search is to start.
  2789. ; Note this definition is changed from Neon.
  2790.  
  2791.     bra    DoPfind
  2792.  
  2793.  
  2794.     head    7,(FINDM),.pfindm        ; (FINDM)
  2795.  
  2796. ; ( hash ^class link-offs -- offs cfa T  |  F )
  2797.  
  2798.     bra    DoPfindM
  2799.  
  2800.  
  2801.  
  2802.     head    4,FIND,find        ; FIND
  2803. ; ( str-addr -- cfa flag  |  -- F )
  2804.  
  2805.     bra    doFind
  2806.  
  2807.  
  2808.     head    5,SFIND,sFind        ; SFIND
  2809. ; ( addr len -- addr' n )
  2810.     parms    pad,place,pad,count,upper
  2811.     parms    pad,find,semis
  2812.  
  2813.  
  2814.     head    8,DEFINED?,defined    ; DEFINED?
  2815.     parms    Mword
  2816.     bra    doFind
  2817.  
  2818.  
  2819.     head    1,',tick        ; '
  2820.     parms    defined,qnotfound,semis
  2821.  
  2822.     head    $43,['],btick        ; [']
  2823.     parms    tick
  2824.     jumph    LitAddr
  2825.  
  2826. ;
  2827. ; LFA is 8 -
  2828. ; NFA is 9 - -1 traverse
  2829. ; PFA is 1 traverse 9 +
  2830. ;
  2831.  
  2832.  
  2833. ;    =============================
  2834.  
  2835. ;        COMPILATION
  2836.  
  2837. ;    =============================
  2838.  
  2839. saveTandS    word
  2840. whichCFA    long
  2841.  
  2842. ; Patches_done is called after any new instructions have been stored, or
  2843. ; patches have been done, and before the instructions are executed.  It
  2844. ; flushes the instruction cache if necessary.
  2845. ; 68030 (and later) chips have an instruction and data cache.  If we
  2846. ; write a new instruction into a location, the 680x0 thinks it was a data
  2847. ; access.  The data cache is correctly updated, but not the instruction
  2848. ; cache.  Then if we try to execute the new instruction too soon, we may
  2849. ; get the old contents of that location from the instruction cache instead.
  2850. ; There are several situations where this could happen, such as when we do
  2851. ; EX-GEN.  The solution is to flush the instruction cache whenever we may be
  2852. ; changing instruction locations where we may have previously been executing.
  2853.  
  2854. ; The Mac OS has a trap (_HWpriv with opcode 1) to do this, but it is only
  2855. ; present on the chips which need it.  Accordingly we check on startup if this
  2856. ; trap is present, and set a flag accordingly.  FlushCache calls the trap if
  2857. ; it is there, and otherwise just returns (no cache to flush, so no problem).
  2858.  
  2859.     head    12,PATCHES_DONE,patchesDone    ; PATCHES_DONE
  2860. FlushCache            ; Old name - outrageous computerese
  2861.     TST.B    HWPavail+3-base(A3)
  2862.     BEQ.S    .out    ; Out if HWPriv trap not available
  2863.     MOVEQ    #1,D0    ; Code 1 means flush the instrn cache
  2864.     exg    a6,a7
  2865.     dc.w    $A198    ; HWPriv trap
  2866.     exg    a6,a7
  2867. .out    RTS
  2868.  
  2869.  
  2870. ; (COMP)  ( cfa -- )  Compiles the word with the given cfa, by
  2871. ; calling its compilation handler.  All compilation should be done
  2872. ; via this word or (COMPN), since they properly allow for words with
  2873. ; optimization etc.  This word assumes a zero opcode is to be passed
  2874. ; to Handlers.  If not, use (COMPN).
  2875.  
  2876.     head    6,(COMP),pcomp        ; (COMP)
  2877.     bra    doPcomp
  2878.  
  2879. ; ANSI synonym:
  2880.     head    8,COMPILE/$2C,.compComma        ; COMPILE,
  2881.     bra    doPcomp
  2882.  
  2883.  
  2884. ; (COMPN)  ( cfa n -- )  is similar to (COMP), but has an additional
  2885. ; parameter n which is the opcode for  -> ++>  etc.
  2886.  
  2887.     head    7,(COMPN),pcompn        ; (COMPN)
  2888.     pop.l    whichCFA-base(a3)
  2889.     bra    pcomp1
  2890.  
  2891.  
  2892.     head    $41,[,lbrack,spec        ; [
  2893. ; Note - immediate so not inline.
  2894.     zVal    state
  2895.     RTS
  2896.  
  2897.     head    $41,],rbrack,spec
  2898.     moveq    #-1,d0
  2899.     move.l    d0,state-base(a3)
  2900.     rts
  2901.  
  2902.  
  2903.     head    $49,IMMEDIATE,.immediate        ; IMMEDIATE
  2904.     n    $40
  2905.     PUSH.L    latest-base(A3)    ; Forward ref
  2906.     parms    cset,semis
  2907.  
  2908.  
  2909. ; In this system, compilation is done by executing the compilation handler
  2910. ; for the word in question.  POSTPONE must therefore be immediate, and
  2911. ; compile the right code into the client definition.  This code consists
  2912. ; of a literal push of the POSTPONEd word's cfa, then a call to (COMP).
  2913.  
  2914.  
  2915.     head    $48,POSTPONE,.postpone        ; POSTPONE
  2916.     parms    defined
  2917.     TST.L    (A6)+
  2918.     BLT.S    .nonimmed
  2919.     BGT    pcomp
  2920.     n    0
  2921.     parms    qnotfound
  2922.  
  2923. .nonimmed
  2924.     callh    LitAddr
  2925.     compyl    pcomp
  2926.     RTS
  2927.  
  2928.  
  2929. ;    ================================
  2930.  
  2931. ;        INTERPRETATION
  2932.  
  2933. ;    ================================
  2934.  
  2935. ; In our native code/STC system, interpreting a word is slightly non-trivial.
  2936. ; We provide two types of execution.  EXECUTE simply JMPs to
  2937. ; the given cfa.  This will work for many words, but not all.  For the
  2938. ; general case we provide another execution word EX-GEN (execute general) 
  2939. ; which compiles the word in a separate buffer, plants a
  2940. ; jump at the end, then branches to the start.  The jump at the end
  2941. ; goes to ChkOK which checks the stack before returning.  EX-GEN is
  2942. ; slower than EXECUTE, but will execute anything.  For this reason
  2943. ; it is called by INTERPRET.  But note, EX-GEN can't be called from an
  2944. ; installed application, since it causes compilation to occur.
  2945.  
  2946.  
  2947.     head    7,EXECUTE,execute        ; EXECUTE
  2948. ; ( cfa -- )
  2949.     pop.l    a1
  2950.     bra    inlck
  2951.  
  2952.  
  2953.     head    9,EX-METHOD,.exMethod        ; EX-METHOD
  2954. ; ( ^obj cfa -- )
  2955.     bra    doExMethod
  2956.  
  2957.  
  2958. ExBuf    byte    100
  2959.  
  2960. chkOK    bra    doChkOK
  2961.  
  2962. xJsrBak    jsr    chkOK-base(A3)
  2963.  
  2964.  
  2965.     head    6,EX-GEN,exgen        ; EX-GEN
  2966.  
  2967. ; ( cfa -- )
  2968.  
  2969.     bra    doExGen
  2970.  
  2971.  
  2972. ; EXN  ( cfa n -- )  is to EX-GEN what (COMPN) is to (COMP).  It
  2973. ; has the additional parameter n which is action code for  -> ++>  etc.
  2974. ; Because this can be called from EX-GEN (which may be executing a prefix
  2975. ; op), we use the alternate execution buffer ExBuf1.
  2976.  
  2977.     head    3,EXN,exN        ; EXN
  2978.  
  2979.     lea    pcompn,A0
  2980.     bra    exgen1
  2981.  
  2982.  
  2983. ; INTERPRET is the interpretation loop.  Words from the input stream are
  2984. ; interpreted until the input is exhausted.
  2985.  
  2986.     head    9,INTERPRET,interpret        ; INTERPRET
  2987.  
  2988.     bra    doInterpret
  2989.  
  2990.  
  2991.     head    6,INTRP1,intrp1        ; INTRP1
  2992. ; ( addr -- ?? )  Interprets one word/number from the input stream.
  2993.     parms    defined
  2994.     tst.l    (a6)+
  2995.     beq.s    .trynum
  2996.     bra    doExGen
  2997.  
  2998. .trynum    parms    number,semis
  2999.  
  3000.  
  3001.     head    2,OK,ok        ; OK
  3002.     bra    doOK
  3003.  
  3004.  
  3005.     head    4,QUIT,quit        ; QUIT
  3006.     bra    doQuit
  3007.  
  3008.  
  3009. ;    ================================
  3010.  
  3011. ;        DEFINING WORDS
  3012.  
  3013. ;    ================================
  3014.  
  3015.     head    8,(HEADER),pheader        ; (HEADER)
  3016.     bra    doPheader
  3017.  
  3018.  
  3019.     head    4,SHDR,sHdr        ; SHDR
  3020. ; ( addr len -- )  Creates a header for the passed-in string.
  3021.     bra    doSHdr
  3022.  
  3023.  
  3024.     head    6,CREATE,create        ; CREATE
  3025.     parms    header
  3026.     comh    create_h
  3027.     RTS
  3028.  
  3029.  
  3030.     head    7,SCREATE,sCreate        ; SCREATE
  3031.     parms    sHdr
  3032.     comh    create_h
  3033.     RTS
  3034.  
  3035.  
  3036.     head    10,CREATE_OBJ,createObj        ; CREATE_OBJ
  3037.     parms    header
  3038.     comh    obj_h
  3039.     RTS
  3040.  
  3041.  
  3042.     head    $44,HIDE,hide        ; HIDE
  3043.  
  3044. ; Hides the name of the current definition from dic searches.
  3045.  
  3046.     PUSH.L    latest-base(A3)    ; Forward ref
  3047.     parms    dup,ntolink,displace
  3048. hide1    parms    swap,thread
  3049.     parms    tuck,minus
  3050.     parms    swap,store,semis
  3051.  
  3052.  
  3053.     head    $46,REVEAL,reveal        ; REVEAL
  3054.  
  3055. ; Makes the current name visible again.
  3056.  
  3057.     PUSH.L    latest-base(A3)    ; Forward ref
  3058.     parms    dup,ntolink
  3059.     BRA.S    hide1
  3060.  
  3061.  
  3062.     head    6,COLHDR,colHdr        ; COLHDR
  3063. ; Lays down the header for a colon definition.
  3064.     parms    header
  3065.     comh    col_h
  3066.     RTS
  3067.  
  3068. ; :NONAME does the work for : once the header has been laid down.
  3069. ; It is also called from other words that begin definitions
  3070. ; such as :proc.
  3071.  
  3072.     head    7,:NONAME,colNoname        ; :NONAME
  3073.     parms    qexec
  3074.     move.l    DP,currDef-base(a3)
  3075.     clr.b    fmkCnt-base(A3)
  3076.     clr.b    callOut-base(A3)
  3077.     parms    rbrack,semis
  3078.  
  3079.  
  3080.     head    $41,:,colon        ; :
  3081.     parms    colHdr,hide,colNoname
  3082.     n    300
  3083.     rts
  3084.  
  3085.  
  3086.     head    7,CLRCOMP,clrComp        ; CLRCOMP
  3087.     zVal    numPL
  3088.     zVal    methodq
  3089.     clr.l    FltFlg-base(a3)
  3090.     sf    colaFlg-base(a3)
  3091. ; ** zero any other flags here!!
  3092.     NoOpt
  3093.     RTS
  3094.  
  3095.     head    3,(/$3B),psemip        ; (;)
  3096.     callh    CompExit
  3097.     tst.b    localq+3-base(A3)
  3098.     bne.s    .sem1
  3099.     bsr.s    clrComp
  3100. .sem1    parms    lbrack,reveal,semis
  3101.  
  3102.     head    $41,/$3B,.semi        ; ;
  3103.     parms    psemip
  3104.     n    300
  3105.     parms    qdefn,semis
  3106.  
  3107.  
  3108.     head    $42,:A,.colA        ; :A
  3109.     parms    colHdr
  3110.     callh    hColA
  3111.     parms    colNoname
  3112.     n    310
  3113.     rts
  3114.  
  3115.     head    $42,/$3BA,.semiA        ; ;A
  3116.     parms    psemip
  3117.     n    310
  3118.     parms    qdefn,semis
  3119.  
  3120.  
  3121.     head    4,CODE,.code        ; CODE
  3122.     BRA    colHdr
  3123.  
  3124.  
  3125. ;    ================
  3126.  
  3127.     head    8,CONSTANT,.constant        ; CONSTANT
  3128.     parms    header
  3129.     comh    const_h
  3130.     parms    comma,semis
  3131.  
  3132.     head    5,VALUE,.value        ; VALUE
  3133.     parms    header
  3134.     comh    val_h
  3135.     parms    comma,semis
  3136.  
  3137.     head    6,OBJPTR,.objPtr        ; OBJPTR
  3138.     parms    header
  3139.     comh    objptr_h
  3140.     parms    nilP,comma
  3141.     n    0
  3142.     parms    comma,semis
  3143.  
  3144.  
  3145. ;    ======= Vectors =======
  3146.  
  3147. xjsrExVect
  3148.     jsr    DoExVect-base(a3)
  3149.  
  3150. xjsrToVect
  3151.     jsr    DoToVect-base(a3)
  3152.  
  3153. DoExVect
  3154.     move.l    (a7)+,a0
  3155.     tst.l    (a0)
  3156.     beq.s    .evDflt
  3157.     bsr    doPAtAbs
  3158.     jmp    (a0)
  3159.  
  3160. .evDflt    jmp    4(a0)
  3161.  
  3162.  
  3163. DoToVect
  3164.     tst.l    (a6)
  3165.     beq.s    .tvDflt
  3166.     bra    rlSt1    ; Dest addr is in A0 already
  3167.  
  3168. .tvDflt    clr.l    (a0)
  3169.     addq    #4,a6
  3170.     rts
  3171.  
  3172.  
  3173.     head    4,VECT,.vect        ; VECT
  3174.     parms    header
  3175.     comh    vect_h
  3176.     push.l    xJsrExVect
  3177.     parms    comma,here
  3178.     n    0
  3179.     parms    comma
  3180.     pop.l    a0
  3181.     bra.s    DoToVect
  3182.  
  3183.  
  3184.     head    8,VARIABLE,.variable        ; VARIABLE
  3185.     parms    create
  3186.     n    0
  3187.     parms    comma,semis
  3188.  
  3189.  
  3190. ; -> (immediate, compilation only) compiles a store to a value
  3191. ; or a vect by passing the otStore opcode to its compilation handler.
  3192. ; This is an interim scheme until  -> is redefined in the file Args.
  3193.  
  3194.     head    $42,->,.to        ; ->
  3195.     n    otStore
  3196. to1    parms    qcomp,tick,swap,pcompn,semis
  3197.  
  3198.  
  3199. ; ++> compiles an increment to a value.
  3200.  
  3201.     head    $43,++>,.plto        ; ++>
  3202.     n    otAdd
  3203.     BRA.S    to1
  3204.  
  3205.  
  3206. ; We retain <BUILDS to be used in conjunction with DOES> rather
  3207. ; than following the standard and using CREATE.  This is because
  3208. ; CREATEd words have the data right at the cfa,
  3209. ; while DOES> words have to have a pointer to the DOES> code.  So rather
  3210. ; than waste space in CREATEd words or do a complicated kludge during
  3211. ; compilation, we use <BUILDS.
  3212.  
  3213. ; To compile a call to a DOES word, we first compile a LEA to the Child's
  3214. ; pfa, then JSR to the DOES code.  At the beginning of the DOES code we
  3215. ; compile a push of A0 to the stack.
  3216.  
  3217.  
  3218.     head    7,<BUILDS,.builds        ; <BUILDS
  3219.     parms    header
  3220.     comh    builds_h
  3221.     n    0
  3222.     parms    comma,semis    ; Will be patched by DODOES
  3223.  
  3224.     nohead    dodoes        ; dodoes
  3225.     parms    rfrom
  3226.     push.l    latest-base(a3)
  3227.     parms    namefrom
  3228.     move.l    (a6),a0
  3229.     moveq    #does_h,d0    ; Change handler to does_h
  3230.     move.w    d0,-2(a0)
  3231.     parms    relocst,semis
  3232.  
  3233.  
  3234.     head    $45,DOES>,.does        ; DOES>
  3235.     compyl    dodoes
  3236.     callh    FixDoes
  3237.     rts
  3238.  
  3239.  
  3240. ;    ==================================
  3241.  
  3242. ;        CONTROL STRUCTURES
  3243.  
  3244. ;    ==================================
  3245.  
  3246. ; We use various devious means to generate short branches in most cases
  3247. ; where these are possible.  The cases where we don't are:
  3248. ;
  3249. ; 1. The forward BRA compiled by ELSE.  When we get to THEN we resolve this,
  3250. ; and we don't find out until then that it could be short.  If we then changed
  3251. ; it, we would also need to change the branch offset compiled by IF
  3252. ; (reducing it by 2).  We would need a new mechanism for keeping track of
  3253. ; where this branch is, which probably isn't worth the bother, especially
  3254. ; as a taken branch takes the same number of cycles on a 68000 regardless
  3255. ; of whether it is short or long.
  3256. ;
  3257. ; 2. Any basic block that contains a short BSR to another word, we don't
  3258. ; allow to be moved, since we don't want to keep track of the location of
  3259. ; such BSRs.  Thus we don't shorten a branch that immediately
  3260. ; precedes such a block.  If the distance was too great for a short BSR, we
  3261. ; use a JSR, if we can, since this can be moved with no problem.
  3262. ;
  3263. ; This arrangement may not be absolutely optimum, but without a horrendous
  3264. ; multi-pass compilation it's about the best we can do - and it's not really
  3265. ; all that bad, anyway.
  3266.  
  3267. ; Note that we must explicitly block optimization at <MARK and >RESOLVE since
  3268. ; two control paths are joining.  We needn't bother at >MARK and <RESOLVE
  3269. ; since a branch is always compiled which will block optimization anyway.
  3270.  
  3271.  
  3272. bran    BRA    .dummy
  3273. qbran    TST.L    (A6)+
  3274.     BNE    .dummy
  3275. zbran    TST.L    (A6)+
  3276.     BEQ    .dummy
  3277.  
  3278.     nohead    compbr        ; compbr
  3279.     MOVE.W    bran,D0
  3280.     PUSH.L    D0
  3281.     parms    wcomma
  3282.     RTS
  3283.  
  3284. .dummy
  3285.  
  3286.     nohead    chkCCmp
  3287.  
  3288. ; ( -- n )
  3289.  
  3290.     MOVEQ    #0,D0
  3291.     MOVE.B    CCmpFlg,D0
  3292.     CLR.B    CCmpFlg-base(A3)
  3293.     PUSH.L    D0
  3294.     RTS
  3295.  
  3296.  
  3297.     head    5,>MARK,fmark        ; >MARK
  3298.     ADDQ.B    #1,fmkCnt-base(A3)
  3299.     parms    chkCCmp,here
  3300.     n    120
  3301.     TST.L    8(A6)
  3302.     BEQ.S    .1
  3303.     parms    pexit
  3304. .1    n    0
  3305.     parms    wcomma,semis
  3306.  
  3307.  
  3308.     head    5,<MARK,bmark        ; <MARK
  3309.     NoOpt    ; Mustn't optimize here
  3310.     parms    here
  3311.     n    121
  3312.     parms    semis
  3313.  
  3314. frBrAd    long
  3315.  
  3316.     head    8,>RESOLVE,fresolve    ; >RESOLVE
  3317.     bra    doFresolve
  3318.  
  3319.     head    9,>RESOLVEN,fresolveN    ; >RESOLVEN
  3320.     ADDQ.B    #1,callOut-base(A3)
  3321.     bsr    doFresolve
  3322.     SUBQ.B    #1,callOut-base(A3)
  3323.     RTS
  3324.  
  3325. brsSh    byte
  3326.     align
  3327.  
  3328.     head    8,<RESOLVE,bresolve        ; <RESOLVE
  3329.  
  3330.     bra    doBresolve
  3331.  
  3332.  
  3333.     head    $42,IF,zif        ; IF
  3334.     parms    true
  3335. if1    callh    pif
  3336.     parms    fmark,semis
  3337.  
  3338.     head    $43,NIF,nif        ; NIF
  3339.     parms    false
  3340.     BRA.S    if1
  3341.  
  3342.     head    $44,ELSE,.zelse        ; ELSE
  3343.  
  3344.     bra    doElse
  3345.  
  3346.  
  3347.     head    $44,THEN,then        ; THEN
  3348.     bra    doFresolve
  3349.  
  3350.     head    $45,BEGIN,.begin        ; BEGIN
  3351.     parms    bmark,semis
  3352.  
  3353.     head    $45,WHILE,.while        ; WHILE
  3354.     parms    zif,semis
  3355.  
  3356.     head    $46,NWHILE,.nwhile        ; NWHILE
  3357.     parms    nif,semis
  3358.  
  3359.     head    $45,UNTIL,.until        ; UNTIL
  3360.     parms    true
  3361. until1    callh    pif
  3362.     bra    doBresolve
  3363.  
  3364.     head    $46,NUNTIL,.nuntil        ; NUNTIL
  3365.     parms    false
  3366.     BRA.S    until1
  3367.  
  3368.     head    $45,AGAIN,again        ; AGAIN
  3369.     parms    compbr
  3370.     bra    doBresolve
  3371.  
  3372.     head    $46,REPEAT,.repeat        ; REPEAT
  3373.  
  3374.     bra    doRepeat
  3375.  
  3376.  
  3377.     head    $42,DO,.do        ; DO
  3378.     compyl    pdo
  3379. do1    SUBQ.L    #6,DP-base(A3)
  3380.     parms    fmark
  3381.     ADDQ.L    #4,DP-base(A3)
  3382.     parms    bmark,semis
  3383.  
  3384.     head    $43,?DO,.qdo        ; ?DO
  3385.     compyl    pqdo
  3386.     BRA.S    do1
  3387.  
  3388.     nohead    fixLoop        ; fixLoop
  3389.     SUBQ.L    #6,DP-base(A3)
  3390.     bsr    doBresolve
  3391.     PUSH.L    windupDo-base(A3)
  3392.     parms    comma,fresolve,semis
  3393.  
  3394.     head    $44,LOOP,.loop        ; LOOP
  3395.     compyl    ploop
  3396.     parms    fixLoop,semis
  3397.  
  3398.     head    $45,+LOOP,.plloop        ; +LOOP
  3399.     callh    CompPlLoop
  3400.     parms    fixLoop,semis
  3401.  
  3402. xLvJmp    JMP    DoLeave-base(A3)
  3403.  
  3404.     head    $45,LEAVE,.leave        ; LEAVE
  3405.     PUSH.L    xLvJmp
  3406.     parms    comma
  3407.     RTS
  3408.  
  3409.  
  3410.     head    6,UNLOOP,.unloop        ; UNLOOP
  3411.     MOVE.L    (A7)+,A0    ; Return address
  3412.     ADDQ.L    #8,A7    ; Pop limit and loop end address
  3413.     MOVE.L    (A7)+,D3    ; Restore old i
  3414.     JMP    (A0)
  3415.  
  3416.  
  3417. ; FOR ... NEXT  as per Charles Moore.  This allows us to use DBRA and
  3418. ; so is very fast.
  3419.  
  3420.     head    $43,FOR,.for        ; FOR
  3421.     PUSH.L    .DoFor
  3422.     parms    comma
  3423.     compop    .doSubq
  3424.     parms    bmark
  3425.     RTS
  3426.  
  3427. .DoFor    MOVE.L    D3,-(A7)
  3428.     POP.L    D3
  3429. .DoSubq    SUBQ.W    #1,D3
  3430.  
  3431.  
  3432.     head    $44,NEXT,.znext        ; NEXT
  3433.     n    121
  3434.     parms    qpairs
  3435.     compop    .xDBRA
  3436.     POP.L    D1    ; Saved DP value
  3437.     SUB.L    dp,D1
  3438.     PUSH.L    D1
  3439.     parms    wcomma
  3440.     compop    .fixNext
  3441.     RTS
  3442.  
  3443. .xDBRA    DBRA    D3,.dummy    ; Dummy destination
  3444.  
  3445. .fixNext
  3446.     MOVE.L    (A7)+,D3
  3447. .dummy
  3448.  
  3449. ; EXIT etc.
  3450.  
  3451.     head    $44,EXIT,.exit        ; EXIT
  3452.     jumph    CompExit
  3453.  
  3454.     head    $45,?EXIT,.qexit        ; ?EXIT
  3455.     parms    zif
  3456. qex1    callh    CompExit
  3457.     parms    then,semis
  3458.  
  3459.     head    $45,0EXIT,.zexit        ; 0EXIT
  3460.     parms    nif
  3461.     BRA.S    qex1
  3462.  
  3463.  
  3464. ;    =================================
  3465.  
  3466. ;        STACK DUMPING, ETC.
  3467.  
  3468. ;    =================================
  3469.  
  3470.     nohead    dotval        ; .val
  3471.     parms    dotr
  3472.     n    2
  3473.     parms    spaces,semis
  3474.  
  3475.  
  3476.     nvec    sPrint
  3477.     _debugger    ; Catch if uninitialized
  3478.  
  3479.  
  3480.     head    5,NAME?,nameq        ; NAME?
  3481. ; ( addr -- addr b )
  3482.     parms    dup,toName,NtoCount
  3483.     parms    plus,aligned,twop,over,eq
  3484.     RTS
  3485.  
  3486.  
  3487. ; CFA? ( cfa? -- cfa? b )  Checks if cfa? could really be a CFA.
  3488.  
  3489.     head    4,CFA?,cfaq        ; CFA?
  3490. ; ( addr -- addr b )
  3491.     bra    doCfaq
  3492.  
  3493.  
  3494.     head    6,CLASS?,classq        ; CLASS?
  3495. ; ( cfa -- cfa b )
  3496. ; Returns true if the cfa refers to a class.
  3497.     bra    doClassq
  3498.  
  3499. theClass    long
  3500. theObj    long
  3501.  
  3502.  
  3503.     head    8,OBJFINDM,.objFindM    ; ObjFindM
  3504.  
  3505. ; ( selID ^obj -- ^obj' cfa )
  3506.  
  3507. ; Finds a method's cfa given a sel ID and an obj addr.
  3508. ; Updates the object's address if necessary - this will happen if the
  3509. ; method turns out to belong to a superclass with a non-zero offset
  3510. ; in the object - i.e. an embedded object.
  3511.  
  3512.     bra    doObjFindM
  3513.  
  3514.  
  3515.     head    7,OBJCFA?,objcfaq        ; OBJCFA?
  3516.  
  3517. ; ( cfa -- cfa b )
  3518.  
  3519. ; Returns true if the cfa refers to a dictionary object.
  3520. ; Note: this won't work for a heap object, since we rely on
  3521. ; the unique handler code for objects being there, and it won't
  3522. ; be for heap objects.  But this is the only way to get a really
  3523. ; rigorous check, which we need for TRAV.  We assume cfa is
  3524. ; really a cfa.
  3525.  
  3526.     bra    doObjCfaq
  3527.  
  3528.  
  3529.     head    6,>CLASS,toClass        ; >CLASS
  3530.  
  3531. ; ( ^obj -- ^class | -- 0 )
  3532.  
  3533. ; Converts an object address to its class address.  Returns zero if the passed-in
  3534. ; address isn't an object address.  Needs to work for heap as well as dictionary
  3535. ; objects.  The test is very unlikely (maybe 1/2**24) to
  3536. ; indicate a non-object as being an object.  Without tagged storage we can't
  3537. ; be absolutely sure.  To save time we don't do a conservative check on ^obj
  3538. ; actually being a legal address (unlike CFA?), apart from checking that it is
  3539. ; even, which is a very quick check.  This means we may crash if an even but illegal
  3540. ; address is passed in.  The presumption is that it really is an object address,
  3541. ; and that anything else is an (unlikely) error.
  3542.  
  3543.     bra    doToClass
  3544.  
  3545.  
  3546.     head    9,>CLASSCFA,.toClassCfa    ; >ClassCfa
  3547.  
  3548. ; ( ^obj -- ^class | -- 0 )
  3549.  
  3550. ; As for >CLASS, but if the class is exported from a module and
  3551. ; you are executing in the main dictionary, it gives the cfa of
  3552. ; the imported word, without accessing the module.  This can be useful
  3553. ; if you just want to identify a class without needing all the class info.
  3554. ; If you are executing in the module, however, you will get the cfa of
  3555. ; the class in the module.  The general rule is that the returned cfa will
  3556. ; always be the same as if you had just ticked the classname, wherever you
  3557. ; are executing.  As for >CLASS, zero is returned if the passed-in address
  3558. ; doesn't point to an object.
  3559.  
  3560.     moveq    #0,d2
  3561.     bra    toClass1
  3562.  
  3563.  
  3564.     head    12,?>CLASSINMOD,.qtoclassInMod    ; ?>ClassInMod
  3565. ; ( ^class -- ^class' )
  3566.  
  3567. ; Converts a class address to the corresponding class address in a module,
  3568. ; if the class is exported, and holds the module.  If the class isn't
  3569. ; exported, does nothing.
  3570.  
  3571.     bra    doQtoClassInMod
  3572.  
  3573.  
  3574.     head    4,OBJ?,objq        ; OBJ?
  3575.  
  3576. ; ( ^obj? -- ^obj? ^class  |  -- ^obj? 0 )
  3577.  
  3578. ; General test for an object.  Not completely rigorous, so we
  3579. ; shouldn't use it in a TRAV, but pretty good nevertheless.  If it is
  3580. ; an object, the class is left in theClass.  We do assume the passed-in
  3581. ; value may not be a legal address at all.
  3582.  
  3583.     bsr    cfaq
  3584.     tst.l    (a6)
  3585.     beq.s    .no
  3586.     move.l    4(a6),(a6)
  3587.     bra    doToClass
  3588.  
  3589. .no    rts
  3590.  
  3591.  
  3592. TheCFA    long
  3593.  
  3594.     head    3,RA?,raq        ; RA?
  3595. ; ( addr -- b )
  3596.     bra    doRAq
  3597.  
  3598.  
  3599.     head    3,.ID,dotid        ; .ID
  3600. ; ( ?cfa -- )
  3601.     parms    cfaq
  3602.     TST.L    (A6)+
  3603.     BEQ.S    .notCfa
  3604.     parms    nameq
  3605.     TST.L    (A6)+
  3606.     BEQ.S    .noName
  3607.     parms    toname,NtoCount,type,pexit
  3608.  
  3609. .noName    msg    (no name)
  3610. .notCfa    parms    drop,semis
  3611.  
  3612.  
  3613.     nohead    dotObjOrRA        ; .objOrRA
  3614. ; ( addr -- )
  3615.     bra    doDotObjOrRA
  3616.  
  3617.  
  3618.     head    $42,DB,.debugger        ; DB
  3619.     n    $a9ff
  3620.     parms    wcomma,semis
  3621.  
  3622.  
  3623.     head    4,(.S),.pDotS        ; (.S)
  3624. ; ( end-addr strt-addr -- )
  3625.     move.l    #1000,d1
  3626.     bra    pDotStk
  3627.  
  3628.     head    2,.S,dots        ; .S
  3629.     bra    doDots
  3630.